diff --git a/C/Makefile b/C/Makefile new file mode 100644 --- /dev/null +++ b/C/Makefile @@ -0,0 +1,15 @@ +XFFLAGS = `pkg-config --libs --cflags libxfconf-0` +CFLAGS = -Wall -Wextra -ansi -pedantic -g $(XFFLAGS) \ + -Wno-missing-field-initializers -Wno-unused-variable +SRCS = demo.c +BINARIES = $(SRCS:.c=) + +all: $(BINARIES) + +%.o: %.c + $(CC) $(CFLAGS) -c $^ + +clean: + -@ rm $(BINARIES) + +.PHONY: clean all diff --git a/C/demo.c b/C/demo.c new file mode 100644 --- /dev/null +++ b/C/demo.c @@ -0,0 +1,367 @@ +/* + * vim:ts=4:sw=4: + */ +#include +#include +#include + +/* from xfconf/common/xfconf-common-private.h */ +#include +#define XFCONF_TYPE_G_VALUE_ARRAY (dbus_g_type_get_collection("GPtrArray", G_TYPE_VALUE)) + +void +print_channels (void) { + gchar **channels = NULL; + gint i; + + channels = xfconf_list_channels (); + for (i = 0; channels[i]; i++) { + g_print ("found channel [%s]\n", channels[i]); + } + g_strfreev (channels); +} + +void +play_with_string (XfconfChannel *chan) { + const gchar *prop = "/String"; + gchar *value; + value = xfconf_channel_get_string (chan, prop, "NA"); + g_print ("%s is [%s]\n", prop, value); + g_free (value); + + if (!xfconf_channel_set_string (chan, prop, "HelloWorld")) { + g_printerr ("ERROR: cannot set xfwm4 theme :(\n"); + } else { + g_print ("Successfully tweak xfwm4 theme\n"); + } +} + +void +play_with_double (XfconfChannel *chan) { + const gchar *prop = "/Double"; + gdouble value; + value = xfconf_channel_get_double (chan, prop, 0.0); + g_print ("%s is [%f]\n", prop, value); + + if (!xfconf_channel_set_double (chan, prop, 3.3)) { + g_printerr ("ERROR: cannot set saturation :(\n"); + } else { + g_print ("Successfully tweak saturation\n"); + } +} + + +/* You can see in the following code that even if we set gvalues + * with xfconf_g_value_set_uint16, when we get them back from the + * xfconfd store, they are UINT and not uint16. + * + * ... this close our pseudo haskell bug :) + */ +void +play_with_uint16 (XfconfChannel* chan) { + const gchar *prop = "/UInt16"; + GValue value = {0}; + + g_value_init(&value, XFCONF_TYPE_UINT16); + xfconf_g_value_set_uint16 (&value, 33); + if (!xfconf_channel_set_property (chan, prop, &value)) + g_error ("cannot set uint16 value to 33\n"); + + g_value_unset(&value); + if (xfconf_channel_get_property (chan, prop, &value)) { + if (G_VALUE_HOLDS (&value, XFCONF_TYPE_UINT16)) { + guint16 x = xfconf_g_value_get_uint16 (&value); + g_print ("%s is an uint16: %u\n", prop, x); + } else if (G_VALUE_HOLDS (&value,G_TYPE_UINT)) { + guint x = g_value_get_uint (&value); + g_print ("%s is an uint: %u\n", prop, x); + } else { + g_error ("Unknown GValue type for our uint16\n"); + } + } else { + g_error ("Cannot get UInt16 GValue !\n"); + } +} + +/* rinse and repeat */ +void +play_with_int16 (XfconfChannel* chan) { + const gchar *prop = "/Int16"; + GValue value = {0}; + + g_value_init(&value, XFCONF_TYPE_INT16); + xfconf_g_value_set_int16 (&value, -33); + if (!xfconf_channel_set_property (chan, prop, &value)) + g_error ("cannot set int16 value to -33\n"); + + g_value_unset(&value); + if (xfconf_channel_get_property (chan, prop, &value)) { + if (G_VALUE_HOLDS (&value, XFCONF_TYPE_INT16)) { + gint16 x = xfconf_g_value_get_int16 (&value); + g_print ("%s is an int16: %d\n", prop, x); + } else if (G_VALUE_HOLDS (&value,G_TYPE_INT)) { + gint x = g_value_get_int (&value); + g_print ("%s is an int: %d\n", prop, x); + } else { + g_error ("Unknown GValue type for our int16\n"); + } + } else { + g_error ("Cannot get Int16 GValue !\n"); + } +} + +GPtrArray *free_my_array (GPtrArray* array) { + unsigned int i; + + if (!array) + return NULL; + + for(i = 0; i < array->len; i++) { + GValue *gvalue = g_ptr_array_index(array, 0); + g_free(gvalue); + } + + g_ptr_array_free(array, TRUE); + + return NULL; +} + +/* Does xfconfd free itself old arrays ??? */ +void +play_with_arrays (XfconfChannel* chan) { + const gchar *prop = "/Array"; + GValue *element0 = g_new0(GValue, 1); + GValue *element1 = g_new0(GValue, 1); + GPtrArray *array0 = g_ptr_array_sized_new(1); + GPtrArray *array1 = g_ptr_array_sized_new(1); + GValue box0 = {0}; + GValue box1 = {0}; + + /* Set array value, first version */ + g_value_init(element0, G_TYPE_STRING); + g_value_set_string(element0, "first item"); + g_ptr_array_add(array0, element0); + g_value_init(&box0, XFCONF_TYPE_G_VALUE_ARRAY); + g_value_set_boxed(&box0, array0); + if (!xfconf_channel_set_property(chan, prop, &box0)) + g_error("fail to set array0\n"); + + g_print("array0.len = %d\n", array0->len); + g_print("array1.len = %d\n", array1->len); + + puts("Press any key to continue"); + getc(stdin); + + /* Set array value, second version */ + g_value_init(element1, G_TYPE_STRING); + g_value_set_string(element1, "second item"); + g_ptr_array_add(array1, element1); + g_value_init(&box1, XFCONF_TYPE_G_VALUE_ARRAY); + g_value_set_boxed(&box1, array1); + if (!xfconf_channel_set_property(chan, prop, &box1)) + g_error("fail to set array1\n"); + + array0 = free_my_array (array0); + array1 = free_my_array (array1); + + if (array0) { + GValue *element = g_ptr_array_index(array0, 0); + if (element) + g_print("array0[0] = %s\n", g_value_get_string(element)); + } + + g_print("array0.len = %d\n", array0 ? array0->len : 0); + g_print("array1.len = %d\n", array1 ? array1->len : 0); + + g_print("conclusion: there is a memory leak when setting new arrays\n"); + +} + +void +print_keys (gpointer data, gpointer user_data) { + gchar *key = data; + if (user_data != NULL) { + g_error ("have you forgotten to set user_data to NULL ?\n"); + return; + } else { + g_print ("found %s\n", key); + } +} + +void +strings_array_print_string(gchar ** strings) +{ + int i; + + if (strings == NULL) { + g_printerr("string array is NULL !\n"); + return; + } + + for (i = 0; ; i++) { + gchar *s = strings[i]; + if (s == NULL) break; + g_print("strings2[%d] = %s\n", i, s); + } +} + +/* Where you can admire the use of GOTOs and why xfconf string list are + * just another type of GPtrArray* + */ +void +play_with_string_list (XfconfChannel *chan) { + GHashTable* table = xfconf_channel_get_properties (chan,"/"); + GList* list = g_hash_table_get_keys(table); + GValue* value; + + g_list_foreach (list, &print_keys, NULL); + + value = g_hash_table_lookup(table, "/Int"); + if (value == NULL) { + g_error("GValue is void, aborting ...\n"); + goto EXIT_STRING_LIST; + } + + g_print ("/Int is %d\n", g_value_get_int(value)); + + g_print ("/Int has type [%s]\n", G_VALUE_TYPE_NAME(value)); + + value = g_hash_table_lookup(table, "/StringList"); + g_print ("/StringList is [%s]\n", G_VALUE_TYPE_NAME(value)); + g_print ("/StringList type id is [%u]\n", (guint)G_VALUE_TYPE(value)); + if (G_VALUE_TYPE(value) == XFCONF_TYPE_G_VALUE_ARRAY) + g_print ("Yes, it is an (xfconf) array\n"); + else + g_print("No, it is not an array, since arrays have type [%u]\n", (guint)G_TYPE_VALUE_ARRAY); + +EXIT_STRING_LIST: + g_list_free(list); + g_hash_table_destroy(table); +} + +/* Silly programmers WILL try to set string lists to an empty array. + * + * A bug in the Haskell xfconf appears when: + * 0) a string list property is intialized to some non-empty array; + * 1) the same property is then set to an empty array (via + * set_string_list or reset_property); + * 2) but the proprety ain't empty, it still holds the previous content. + * + * This function checks in C that xfconf_channel_reset_property + * correctly set an empty array. + */ +void +play_with_null_string_list (XfconfChannel *chan) { + const gchar prop[20] = "/StringList"; + const gchar * const strings[] = { "one", "two", "three", NULL }; + const gchar * const strings0[] = { NULL }; + gchar **strings2 = NULL; + int ret; + + g_print("Setting string array to:\n"); + strings_array_print_string((gchar **)strings); + + ret = xfconf_channel_set_string_list(chan, prop, strings); + if (ret == FALSE) { + g_print("Cannot set string array !\n"); + } + + g_print("Array retrieved is now:\n"); + strings2 = xfconf_channel_get_string_list(chan, prop); + strings_array_print_string(strings2); + g_strfreev(strings2); + strings2 = NULL; + + g_print("And now for something completely different ...\n"); + g_print("... setting the property to an empty array !\n"); + xfconf_channel_reset_property(chan, prop, FALSE); + + g_print("retreived array is:\n"); + strings2 = xfconf_channel_get_string_list(chan, prop); + strings_array_print_string(strings2); + + ret = xfconf_channel_set_string_list(chan, prop, strings0); + if (ret == FALSE) { + g_print("Cannot set NULL string array !\n"); + } + + ret = xfconf_channel_set_string_list(chan, prop, NULL); + if (ret == FALSE) { + g_print("Cannot set NULL string array !\n"); + } +} + +/* when xfconf_channel_get_property returns false, the GValue* is + * uninitialized and we cannot unset it safely */ +void +play_with_gvalue_bug (XfconfChannel* chan) { + GValue gvalue = {0}; + const gchar* prop = "/notExisitingProperty"; + + xfconf_channel_get_property (chan, prop, &gvalue); + + if (G_IS_VALUE(&gvalue)) + g_print ("I've got a valid value !\n"); + else + g_print ("unvalid gvalue !\n"); +} + +int +main (void) { + GError *error = NULL; + const gchar name[20] = "quickcheck"; + + /* init */ + xfconf_init (&error); + if (error != NULL) { + g_printerr( "an error with code %d occured: %s\n", + error->code, error->message); + g_clear_error (&error); + return EXIT_FAILURE; + } + else + printf ("Hello world of xfconf !\n"); + + /* list channels */ + /*print_channels ();*/ + + /* play with values get/set */ + { + XfconfChannel *chan = xfconf_channel_get (name); + + if (chan == NULL) { + g_critical("Failed to connect to \"%s\" channel\n", name); + return EXIT_FAILURE; + } + + /* string */ + /*play_with_string (chan);*/ + + /* double */ + /*play_with_double (chan);*/ + + /* uint16 */ + /*play_with_uint16 (chan);*/ + + /* uint16 */ + /*play_with_int16 (chan);*/ + + /* StringList */ + /*play_with_string_list (chan);*/ + + /* Array */ + /*play_with_arrays (chan);*/ + + /* GValue bug */ + /*play_with_gvalue_bug (chan);*/ + + /* Empty string array. */ + play_with_null_string_list (chan); + } + + xfconf_shutdown (); + return EXIT_SUCCESS; +} +/* + * vim:tabstop=4: + */ diff --git a/Demo/Demo.hs b/Demo/Demo.hs new file mode 100644 --- /dev/null +++ b/Demo/Demo.hs @@ -0,0 +1,102 @@ +-- A simple demo program for xfconf. +-- Required gtk >= 0.12. +-- +module Main where + +import Control.Monad (forM_) + +import Graphics.UI.Gtk + +import System.XFCE.Xfconf + +main :: IO () +main = createWindow + +createWindow :: IO () +createWindow = do + -- normally returns the remaining command line arguments + initGUI + + -- Our special xfconf channel + chan <- channelGet "Demo" + + -- Create window and main container + window <- windowNew + grid <- tableNew 4 3 False -- rows, columns, homogenous + set grid [ tableRowSpacing := 10 ] + set window [ windowTitle := "Xfconf Binding demo" + , containerBorderWidth := 10 + , containerChild := grid ] + onDestroy window $ do + mainQuit + putStrLn "ByeBye" + + -- * Create container content + -- ** First line: instruction + instruction <- labelNew (Just + "This window demonstrates the binding between Gtk\ + \ CheckButtons, the xfconf backend and Gtk Labels. Every time\ + \ you (un)check one of the button, xfconf is updated\ + \ accordingly and its state is mirrored in both the label and\ + \ the other button.") + labelSetJustify instruction JustifyCenter + set instruction [ labelWrap := True + , labelWidthChars := 80 + , labelSingleLineMode := False ] + tableAttachDefaults grid instruction 0 3 0 1 + + -- ** Second line: titles + title0 <- labelNew (Just "Ur button") + title1 <- labelNew (Just "Xfconf value") + title2 <- labelNew (Just "Mirror button") + forM_ [(title0,0,1), (title1,1,2), (title2,2,3)] $ \(w,l,r) -> do + labelSetUseMarkup w True + tableAttachDefaults grid w l r 1 2 + + -- ** Third line: check/label + check0 <- checkButtonNewWithLabel "Check me !" + label0 <- labelNew (Just "") + check1 <- checkButtonNewWithLabel "Check me !" + tableAttachDefaults grid check0 0 1 2 3 + tableAttachDefaults grid label0 1 2 2 3 + tableAttachDefaults grid check1 2 3 2 3 + set grid [ tableChildXOptions check0 := [] + , tableChildXOptions label0 := [] + , tableChildXOptions check1 := [] ] + + -- Signals voodoo \o/ + -- * xfconf binding + xfsig0 <- xfconfBind chan "/check" bool check0 "active" + xfsig1 <- xfconfBind chan "/check" bool check1 "active" + -- * xfconf monitoring + onPropertyChanged chan $ \key maybeValue -> do + if key /= "/check" + then return () + else case maybeValue of + Just (XfconfBool True) -> labelSetText label0 "checked !" + Just (XfconfBool False) -> labelSetText label0 "unchecked !" + _ -> labelSetText label0 "UNKNOWN" + + + -- ** Fourth line: test unbind(s) + breakMe0 <- buttonNewWithLabel "Unbind" + breakMe1 <- buttonNewWithLabel "Unbind all" + breakMe2 <- buttonNewWithLabel "Unbind property" + tableAttachDefaults grid breakMe0 0 1 3 4 + tableAttachDefaults grid breakMe1 1 2 3 4 + tableAttachDefaults grid breakMe2 2 3 3 4 + onClicked breakMe0 $ do + xfconfUnbind xfsig0 + xfconfUnbind xfsig1 + onClicked breakMe1 $ do + xfconfUnbindAll check0 + xfconfUnbindAll chan + onClicked breakMe2 $ do + xfconfUnbindByProperty chan "/check" check0 "active" + xfconfUnbindByProperty chan "/check" check1 "active" + + -- END + widgetShowAll window + + mainGUI + diff --git a/Gtk2HsSetup.hs b/Gtk2HsSetup.hs new file mode 100644 --- /dev/null +++ b/Gtk2HsSetup.hs @@ -0,0 +1,511 @@ +{-# LANGUAGE CPP #-} + +#define CABAL_VERSION_ENCODE(major, minor, micro) ( \ + ((major) * 10000) \ + + ((minor) * 100) \ + + ((micro) * 1)) + +#define CABAL_VERSION_CHECK(major,minor,micro) \ + (CABAL_VERSION >= CABAL_VERSION_ENCODE(major,minor,micro)) + +-- now, this is bad, but Cabal doesn't seem to actually pass any information about +-- its version to CPP, so guess the version depending on the version of GHC +#ifdef CABAL_VERSION_MINOR +#ifndef CABAL_VERSION_MAJOR +#define CABAL_VERSION_MAJOR 1 +#endif +#ifndef CABAL_VERSION_MICRO +#define CABAL_VERSION_MICRO 0 +#endif +#define CABAL_VERSION CABAL_VERSION_ENCODE( \ + CABAL_VERSION_MAJOR, \ + CABAL_VERSION_MINOR, \ + CABAL_VERSION_MICRO) +#else +#warning Setup.hs is guessing the version of Cabal. If compilation of Setup.hs fails use -DCABAL_VERSION_MINOR=x for Cabal version 1.x.0 when building (prefixed by --ghc-option= when using the 'cabal' command) +#if (__GLASGOW_HASKELL__ >= 700) +#define CABAL_VERSION CABAL_VERSION_ENCODE(1,10,0) +#else +#if (__GLASGOW_HASKELL__ >= 612) +#define CABAL_VERSION CABAL_VERSION_ENCODE(1,8,0) +#else +#define CABAL_VERSION CABAL_VERSION_ENCODE(1,6,0) +#endif +#endif +#endif + +-- | Build a Gtk2hs package. +-- +module Gtk2HsSetup ( + gtk2hsUserHooks, + getPkgConfigPackages, + checkGtk2hsBuildtools + ) where + +import Distribution.Simple +import Distribution.Simple.PreProcess +import Distribution.InstalledPackageInfo ( importDirs, + showInstalledPackageInfo, + libraryDirs, + extraLibraries, + extraGHCiLibraries ) +import Distribution.Simple.PackageIndex ( +#if CABAL_VERSION_CHECK(1,8,0) + lookupInstalledPackageId +#else + lookupPackageId +#endif + ) +import Distribution.PackageDescription as PD ( PackageDescription(..), + updatePackageDescription, + BuildInfo(..), + emptyBuildInfo, allBuildInfo, + Library(..), + libModules, hasLibs) +import Distribution.Simple.LocalBuildInfo (LocalBuildInfo(..), + InstallDirs(..), +#if CABAL_VERSION_CHECK(1,8,0) + componentPackageDeps, +#else + packageDeps, +#endif + absoluteInstallDirs) +import Distribution.Simple.Compiler ( Compiler(..) ) +import Distribution.Simple.Program ( + Program(..), ConfiguredProgram(..), + rawSystemProgramConf, rawSystemProgramStdoutConf, programName, + c2hsProgram, pkgConfigProgram, requireProgram, ghcPkgProgram, + simpleProgram, lookupProgram, rawSystemProgramStdout, ProgArg) +import Distribution.ModuleName ( ModuleName, components, toFilePath ) +import Distribution.Simple.Utils +import Distribution.Simple.Setup (CopyFlags(..), InstallFlags(..), CopyDest(..), + defaultCopyFlags, ConfigFlags(configVerbosity), + fromFlag, toFlag, RegisterFlags(..), flagToMaybe, + fromFlagOrDefault, defaultRegisterFlags) +import Distribution.Simple.BuildPaths ( autogenModulesDir ) +import Distribution.Simple.Install ( install ) +#if CABAL_VERSION_CHECK(1,8,0) +import Distribution.Simple.Register ( generateRegistrationInfo, registerPackage ) +#else +import qualified Distribution.Simple.Register as Register ( register ) +#endif +import Distribution.Text ( simpleParse, display ) +import System.FilePath +import System.Exit (exitFailure) +import System.Directory ( doesFileExist, getDirectoryContents, doesDirectoryExist ) +import Distribution.Version (Version(..)) +import Distribution.Verbosity +import Control.Monad (when, unless, filterM, liftM, forM, forM_) +import Data.Maybe ( isJust, isNothing, fromMaybe, maybeToList ) +import Data.List (isPrefixOf, isSuffixOf, nub) +import Data.Char (isAlpha) +import qualified Data.Map as M +import qualified Data.Set as S + +import Control.Applicative ((<$>)) + +-- the name of the c2hs pre-compiled header file +precompFile = "precompchs.bin" + +gtk2hsUserHooks = simpleUserHooks { + hookedPrograms = [typeGenProgram, signalGenProgram, c2hsLocal], + hookedPreProcessors = [("chs", ourC2hs)], + confHook = \pd cf -> + (fmap adjustLocalBuildInfo (confHook simpleUserHooks pd cf)), + postConf = \args cf pd lbi -> do + genSynthezisedFiles (fromFlag (configVerbosity cf)) pd lbi + postConf simpleUserHooks args cf pd lbi, + buildHook = \pd lbi uh bf -> fixDeps pd >>= \pd -> + buildHook simpleUserHooks pd lbi uh bf, + copyHook = \pd lbi uh flags -> copyHook simpleUserHooks pd lbi uh flags >> + installCHI pd lbi (fromFlag (copyVerbosity flags)) (fromFlag (copyDest flags)), + instHook = \pd lbi uh flags -> +#if defined(mingw32_HOST_OS) || defined(__MINGW32__) + installHook pd lbi uh flags >> + installCHI pd lbi (fromFlag (installVerbosity flags)) NoCopyDest, + regHook = registerHook +#else + instHook simpleUserHooks pd lbi uh flags >> + installCHI pd lbi (fromFlag (installVerbosity flags)) NoCopyDest +#endif + } + +------------------------------------------------------------------------------ +-- Lots of stuff for windows ghci support +------------------------------------------------------------------------------ + +getDlls :: [FilePath] -> IO [FilePath] +getDlls dirs = filter ((== ".dll") . takeExtension) . concat <$> + mapM getDirectoryContents dirs + +fixLibs :: [FilePath] -> [String] -> [String] +fixLibs dlls = concatMap $ \ lib -> + case filter (("lib" ++ lib) `isPrefixOf`) dlls of + dll:_ -> [dropExtension dll] + _ -> if lib == "z" then [] else [lib] + +-- The following code is a big copy-and-paste job from the sources of +-- Cabal 1.8 just to be able to fix a field in the package file. Yuck. + +#if CABAL_VERSION_CHECK(1,8,0) + +installHook :: PackageDescription -> LocalBuildInfo + -> UserHooks -> InstallFlags -> IO () +installHook pkg_descr localbuildinfo _ flags = do + let copyFlags = defaultCopyFlags { + copyDistPref = installDistPref flags, + copyDest = toFlag NoCopyDest, + copyVerbosity = installVerbosity flags + } + install pkg_descr localbuildinfo copyFlags + let registerFlags = defaultRegisterFlags { + regDistPref = installDistPref flags, + regInPlace = installInPlace flags, + regPackageDB = installPackageDB flags, + regVerbosity = installVerbosity flags + } + when (hasLibs pkg_descr) $ register pkg_descr localbuildinfo registerFlags + +registerHook :: PackageDescription -> LocalBuildInfo + -> UserHooks -> RegisterFlags -> IO () +registerHook pkg_descr localbuildinfo _ flags = + if hasLibs pkg_descr + then register pkg_descr localbuildinfo flags + else setupMessage verbosity + "Package contains no library to register:" (packageId pkg_descr) + where verbosity = fromFlag (regVerbosity flags) + +register :: PackageDescription -> LocalBuildInfo + -> RegisterFlags -- ^Install in the user's database?; verbose + -> IO () +register pkg@PackageDescription { library = Just lib } + lbi@LocalBuildInfo { libraryConfig = Just clbi } regFlags + = do + + installedPkgInfoRaw <- generateRegistrationInfo + verbosity pkg lib lbi clbi inplace distPref + + dllsInScope <- getSearchPath >>= (filterM doesDirectoryExist) >>= getDlls + let libs = fixLibs dllsInScope (extraLibraries installedPkgInfoRaw) + installedPkgInfo = installedPkgInfoRaw { + extraGHCiLibraries = libs } + + -- Three different modes: + case () of + _ | modeGenerateRegFile -> die "Generate Reg File not supported" + | modeGenerateRegScript -> die "Generate Reg Script not supported" + | otherwise -> registerPackage verbosity +#if CABAL_VERSION_CHECK(1,10,0) + installedPkgInfo pkg lbi inplace [packageDb] +#else + installedPkgInfo pkg lbi inplace packageDb +#endif + + where + modeGenerateRegFile = isJust (flagToMaybe (regGenPkgConf regFlags)) + modeGenerateRegScript = fromFlag (regGenScript regFlags) + inplace = fromFlag (regInPlace regFlags) + packageDb = case flagToMaybe (regPackageDB regFlags) of + Just db -> db + Nothing -> registrationPackageDB (withPackageDB lbi) + distPref = fromFlag (regDistPref regFlags) + verbosity = fromFlag (regVerbosity regFlags) + +register _ _ regFlags = notice verbosity "No package to register" + where + verbosity = fromFlag (regVerbosity regFlags) + +#else +installHook :: PackageDescription -> LocalBuildInfo + -> UserHooks -> InstallFlags -> IO () +installHook pkg_descr localbuildinfo _ flags = do + let copyFlags = defaultCopyFlags { + copyDistPref = installDistPref flags, + copyInPlace = installInPlace flags, + copyUseWrapper = installUseWrapper flags, + copyDest = toFlag NoCopyDest, + copyVerbosity = installVerbosity flags + } + install pkg_descr localbuildinfo copyFlags + let registerFlags = defaultRegisterFlags { + regDistPref = installDistPref flags, + regInPlace = installInPlace flags, + regPackageDB = installPackageDB flags, + regVerbosity = installVerbosity flags + } + when (hasLibs pkg_descr) $ register pkg_descr localbuildinfo registerFlags + +registerHook :: PackageDescription -> LocalBuildInfo + -> UserHooks -> RegisterFlags -> IO () +registerHook pkg_descr localbuildinfo _ flags = + if hasLibs pkg_descr + then register pkg_descr localbuildinfo flags + else setupMessage verbosity + "Package contains no library to register:" (packageId pkg_descr) + where verbosity = fromFlag (regVerbosity flags) + +register :: PackageDescription -> LocalBuildInfo + -> RegisterFlags -- ^Install in the user's database?; verbose + -> IO () +register pkg_descr lbi regFlags = do + let verbosity = fromFlag (regVerbosity regFlags) + warn verbosity "Cannot register ghci libraries with Cabal 1.6 (need 1.8)." + Register.register pkg_descr lbi regFlags + +#endif + +------------------------------------------------------------------------------ +-- This is a hack for Cabal-1.8, It is not needed in Cabal-1.9.1 or later +------------------------------------------------------------------------------ + +adjustLocalBuildInfo :: LocalBuildInfo -> LocalBuildInfo +adjustLocalBuildInfo lbi = + let extra = (Just libBi, []) + libBi = emptyBuildInfo { includeDirs = [ autogenModulesDir lbi + , buildDir lbi ] } + in lbi { localPkgDescr = updatePackageDescription extra (localPkgDescr lbi) } + +------------------------------------------------------------------------------ +-- Processing .chs files with our local c2hs. +------------------------------------------------------------------------------ + +ourC2hs :: BuildInfo -> LocalBuildInfo -> PreProcessor +ourC2hs bi lbi = PreProcessor { + platformIndependent = False, + runPreProcessor = runC2HS bi lbi +} + +runC2HS :: BuildInfo -> LocalBuildInfo -> + (FilePath, FilePath) -> (FilePath, FilePath) -> Verbosity -> IO () +runC2HS bi lbi (inDir, inFile) (outDir, outFile) verbosity = do + -- have the header file name if we don't have the precompiled header yet + header <- case lookup "x-c2hs-header" (customFieldsBI bi) of + Just h -> return h + Nothing -> die ("Need x-c2hs-Header definition in the .cabal Library section "++ + "that sets the C header file to process .chs.pp files.") + + -- c2hs will output files in out dir, removing any leading path of the input file. + -- Thus, append the dir of the input file to the output dir. + let (outFileDir, newOutFile) = splitFileName outFile + let newOutDir = outDir outFileDir + -- additional .chi files might be needed that other packages have installed; + -- we assume that these are installed in the same place as .hi files + let chiDirs = [ dir | +#if CABAL_VERSION_CHECK(1,8,0) + ipi <- maybe [] (map fst . componentPackageDeps) (libraryConfig lbi), + dir <- maybe [] importDirs (lookupInstalledPackageId (installedPkgs lbi) ipi) ] +#else + ipi <- packageDeps lbi, + dir <- maybe [] importDirs (lookupPackageId (installedPkgs lbi) ipi) ] +#endif + rawSystemProgramConf verbosity c2hsLocal (withPrograms lbi) $ + map ("--include=" ++) (outDir:chiDirs) + ++ ["--cppopts=" ++ opt | opt <- getCppOptions bi lbi] + ++ ["--output-dir=" ++ newOutDir, + "--output=" ++ newOutFile, + "--precomp=" ++ buildDir lbi precompFile, + header, inDir inFile] + +getCppOptions :: BuildInfo -> LocalBuildInfo -> [String] +getCppOptions bi lbi + = nub $ + ["-I" ++ dir | dir <- PD.includeDirs bi] + ++ [opt | opt@('-':c:_) <- PD.cppOptions bi ++ PD.ccOptions bi, c `elem` "DIU"] + +installCHI :: PackageDescription -- ^information from the .cabal file + -> LocalBuildInfo -- ^information from the configure step + -> Verbosity -> CopyDest -- ^flags sent to copy or install + -> IO () +installCHI pkg@PD.PackageDescription { library = Just lib } lbi verbosity copydest = do + let InstallDirs { libdir = libPref } = absoluteInstallDirs pkg lbi copydest + -- cannot use the recommended 'findModuleFiles' since it fails if there exists + -- a modules that does not have a .chi file + mFiles <- mapM (findFileWithExtension' ["chi"] [buildDir lbi] . toFilePath) +#if CABAL_VERSION_CHECK(1,8,0) + (PD.libModules lib) +#else + (PD.libModules pkg) +#endif + + let files = [ f | Just f <- mFiles ] +#if CABAL_VERSION_CHECK(1,8,0) + installOrdinaryFiles verbosity libPref files +#else + copyFiles verbosity libPref files +#endif + + +installCHI _ _ _ _ = return () + +------------------------------------------------------------------------------ +-- Generating the type hierarchy and signal callback .hs files. +------------------------------------------------------------------------------ + +typeGenProgram :: Program +typeGenProgram = simpleProgram "gtk2hsTypeGen" + +signalGenProgram :: Program +signalGenProgram = simpleProgram "gtk2hsHookGenerator" + +c2hsLocal :: Program +c2hsLocal = simpleProgram "gtk2hsC2hs" + +genSynthezisedFiles :: Verbosity -> PackageDescription -> LocalBuildInfo -> IO () +genSynthezisedFiles verb pd lbi = do + + cPkgs <- getPkgConfigPackages verb lbi pd + + let xList = maybe [] (customFieldsBI . libBuildInfo) (library pd) + ++customFieldsPD pd + typeOpts :: String -> [ProgArg] + typeOpts tag = concat [ map (\val -> '-':'-':drop (length tag) field++'=':val) (words content) + | (field,content) <- xList, + tag `isPrefixOf` field, + field /= (tag++"file")] + ++ [ "--tag=" ++ tag + | PackageIdentifier name (Version (major:minor:_) _) <- cPkgs + , let name' = filter isAlpha (display name) + , tag <- name' + : [ name' ++ "-" ++ show major ++ "." ++ show digit + | digit <- [0,2..minor] ] + ] + + signalsOpts :: [ProgArg] + signalsOpts = concat [ map (\val -> '-':'-':drop 10 field++'=':val) (words content) + | (field,content) <- xList, + "x-signals-" `isPrefixOf` field, + field /= "x-signals-file"] + + genFile :: Program -> [ProgArg] -> FilePath -> IO () + genFile prog args outFile = do + res <- rawSystemProgramStdoutConf verb prog (withPrograms lbi) args + rewriteFile outFile res + + forM_ (filter (\(tag,_) -> "x-types-" `isPrefixOf` tag && "file" `isSuffixOf` tag) xList) $ + \(fileTag, f) -> do + let tag = reverse (drop 4 (reverse fileTag)) + info verb ("Ensuring that class hierarchy in "++f++" is up-to-date.") + genFile typeGenProgram (typeOpts tag) f + + case lookup "x-signals-file" xList of + Nothing -> return () + Just f -> do + info verb ("Ensuring that callback hooks in "++f++" are up-to-date.") + genFile signalGenProgram signalsOpts f + +--FIXME: Cabal should tell us the selected pkg-config package versions in the +-- LocalBuildInfo or equivalent. +-- In the mean time, ask pkg-config again. + +getPkgConfigPackages :: Verbosity -> LocalBuildInfo -> PackageDescription -> IO [PackageId] +getPkgConfigPackages verbosity lbi pkg = + sequence + [ do version <- pkgconfig ["--modversion", display pkgname] + case simpleParse version of + Nothing -> die "parsing output of pkg-config --modversion failed" + Just v -> return (PackageIdentifier pkgname v) + | Dependency pkgname _ <- concatMap pkgconfigDepends (allBuildInfo pkg) ] + where + pkgconfig = rawSystemProgramStdoutConf verbosity + pkgConfigProgram (withPrograms lbi) + +------------------------------------------------------------------------------ +-- Dependency calculation amongst .chs files. +------------------------------------------------------------------------------ + +-- Given all files of the package, find those that end in .chs and extract the +-- .chs files they depend upon. Then return the PackageDescription with these +-- files rearranged so that they are built in a sequence that files that are +-- needed by other files are built first. +fixDeps :: PackageDescription -> IO PackageDescription +fixDeps pd@PD.PackageDescription { + PD.library = Just lib@PD.Library { + PD.exposedModules = expMods, + PD.libBuildInfo = bi@PD.BuildInfo { + PD.hsSourceDirs = srcDirs, + PD.otherModules = othMods + }}} = do + let findModule m = findFileWithExtension [".chs.pp",".chs"] srcDirs + (joinPath (components m)) + mExpFiles <- mapM findModule expMods + mOthFiles <- mapM findModule othMods + + -- tag all exposed files with True so we throw an error if we need to build + -- an exposed module before an internal modules (we cannot express this) + let modDeps = zipWith (ModDep True []) expMods mExpFiles++ + zipWith (ModDep False []) othMods mOthFiles + modDeps <- mapM extractDeps modDeps + let (expMods, othMods) = span mdExposed $ sortTopological modDeps + badOther = map (fromMaybe "" . mdLocation) $ + filter (not . mdExposed) expMods + unless (null badOther) $ + die ("internal chs modules "++intercalate "," badOther++ + " depend on exposed chs modules; cabal needs to build internal modules first") + return pd { PD.library = Just lib { + PD.exposedModules = map mdOriginal expMods, + PD.libBuildInfo = bi { PD.otherModules = map mdOriginal othMods } + }} + +data ModDep = ModDep { + mdExposed :: Bool, + mdRequires :: [ModuleName], + mdOriginal :: ModuleName, + mdLocation :: Maybe FilePath +} + +instance Show ModDep where + show x = show (mdLocation x) + +instance Eq ModDep where + ModDep { mdOriginal = m1 } == ModDep { mdOriginal = m2 } = m1==m2 +instance Ord ModDep where + compare ModDep { mdOriginal = m1 } ModDep { mdOriginal = m2 } = compare m1 m2 + +-- Extract the dependencies of this file. This is intentionally rather naive as it +-- ignores CPP conditionals. We just require everything which means that the +-- existance of a .chs module may not depend on some CPP condition. +extractDeps :: ModDep -> IO ModDep +extractDeps md@ModDep { mdLocation = Nothing } = return md +extractDeps md@ModDep { mdLocation = Just f } = withUTF8FileContents f $ \con -> do + let findImports acc (('{':'#':xs):xxs) = case (dropWhile (' ' ==) xs) of + ('i':'m':'p':'o':'r':'t':' ':ys) -> + case simpleParse (takeWhile ('#' /=) ys) of + Just m -> findImports (m:acc) xxs + Nothing -> die ("cannot parse chs import in "++f++":\n"++ + "offending line is {#"++xs) + -- no more imports after the first non-import hook + _ -> return acc + findImports acc (_:xxs) = findImports acc xxs + findImports acc [] = return acc + mods <- findImports [] (lines con) + return md { mdRequires = mods } + +-- Find a total order of the set of modules that are partially sorted by their +-- dependencies on each other. The function returns the sorted list of modules +-- together with a list of modules that are required but not supplied by this +-- in the input set of modules. +sortTopological :: [ModDep] -> [ModDep] +sortTopological ms = reverse $ fst $ foldl visit ([], S.empty) (map mdOriginal ms) + where + set = M.fromList (map (\m -> (mdOriginal m, m)) ms) + visit (out,visited) m + | m `S.member` visited = (out,visited) + | otherwise = case m `M.lookup` set of + Nothing -> (out, m `S.insert` visited) + Just md -> (md:out', visited') + where + (out',visited') = foldl visit (out, m `S.insert` visited) (mdRequires md) + +-- Check user whether install gtk2hs-buildtools correctly. +checkGtk2hsBuildtools :: [String] -> IO () +checkGtk2hsBuildtools programs = do + programInfos <- mapM (\ name -> do + location <- programFindLocation (simpleProgram name) normal + return (name, location) + ) programs + let printError name = do + putStrLn $ "Cannot find " ++ name ++ "\n" + ++ "Please install `gtk2hs-buildtools` first and check that the install directory is in your PATH (e.g. HOME/.cabal/bin)." + exitFailure + forM_ programInfos $ \ (name, location) -> + when (isNothing location) (printError name) diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,675 @@ + GNU GENERAL PUBLIC LICENSE + Version 3, 29 June 2007 + + Copyright (C) 2007 Free Software Foundation, Inc. + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + + Preamble + + The GNU General Public License is a free, copyleft license for +software and other kinds of works. + + The licenses for most software and other practical works are designed +to take away your freedom to share and change the works. By contrast, +the GNU General Public License is intended to guarantee your freedom to +share and change all versions of a program--to make sure it remains free +software for all its users. We, the Free Software Foundation, use the +GNU General Public License for most of our software; it applies also to +any other work released this way by its authors. You can apply it to +your programs, too. + + When we speak of free software, we are referring to freedom, not +price. Our General Public Licenses are designed to make sure that you +have the freedom to distribute copies of free software (and charge for +them if you wish), that you receive source code or can get it if you +want it, that you can change the software or use pieces of it in new +free programs, and that you know you can do these things. + + To protect your rights, we need to prevent others from denying you +these rights or asking you to surrender the rights. Therefore, you have +certain responsibilities if you distribute copies of the software, or if +you modify it: responsibilities to respect the freedom of others. + + For example, if you distribute copies of such a program, whether +gratis or for a fee, you must pass on to the recipients the same +freedoms that you received. You must make sure that they, too, receive +or can get the source code. And you must show them these terms so they +know their rights. + + Developers that use the GNU GPL protect your rights with two steps: +(1) assert copyright on the software, and (2) offer you this License +giving you legal permission to copy, distribute and/or modify it. + + For the developers' and authors' protection, the GPL clearly explains +that there is no warranty for this free software. For both users' and +authors' sake, the GPL requires that modified versions be marked as +changed, so that their problems will not be attributed erroneously to +authors of previous versions. + + Some devices are designed to deny users access to install or run +modified versions of the software inside them, although the manufacturer +can do so. This is fundamentally incompatible with the aim of +protecting users' freedom to change the software. The systematic +pattern of such abuse occurs in the area of products for individuals to +use, which is precisely where it is most unacceptable. Therefore, we +have designed this version of the GPL to prohibit the practice for those +products. If such problems arise substantially in other domains, we +stand ready to extend this provision to those domains in future versions +of the GPL, as needed to protect the freedom of users. + + Finally, every program is threatened constantly by software patents. +States should not allow patents to restrict development and use of +software on general-purpose computers, but in those that do, we wish to +avoid the special danger that patents applied to a free program could +make it effectively proprietary. To prevent this, the GPL assures that +patents cannot be used to render the program non-free. + + The precise terms and conditions for copying, distribution and +modification follow. + + TERMS AND CONDITIONS + + 0. Definitions. + + "This License" refers to version 3 of the GNU General Public License. + + "Copyright" also means copyright-like laws that apply to other kinds of +works, such as semiconductor masks. + + "The Program" refers to any copyrightable work licensed under this +License. Each licensee is addressed as "you". "Licensees" and +"recipients" may be individuals or organizations. + + To "modify" a work means to copy from or adapt all or part of the work +in a fashion requiring copyright permission, other than the making of an +exact copy. The resulting work is called a "modified version" of the +earlier work or a work "based on" the earlier work. + + A "covered work" means either the unmodified Program or a work based +on the Program. + + To "propagate" a work means to do anything with it that, without +permission, would make you directly or secondarily liable for +infringement under applicable copyright law, except executing it on a +computer or modifying a private copy. Propagation includes copying, +distribution (with or without modification), making available to the +public, and in some countries other activities as well. + + To "convey" a work means any kind of propagation that enables other +parties to make or receive copies. Mere interaction with a user through +a computer network, with no transfer of a copy, is not conveying. + + An interactive user interface displays "Appropriate Legal Notices" +to the extent that it includes a convenient and prominently visible +feature that (1) displays an appropriate copyright notice, and (2) +tells the user that there is no warranty for the work (except to the +extent that warranties are provided), that licensees may convey the +work under this License, and how to view a copy of this License. If +the interface presents a list of user commands or options, such as a +menu, a prominent item in the list meets this criterion. + + 1. Source Code. + + The "source code" for a work means the preferred form of the work +for making modifications to it. "Object code" means any non-source +form of a work. + + A "Standard Interface" means an interface that either is an official +standard defined by a recognized standards body, or, in the case of +interfaces specified for a particular programming language, one that +is widely used among developers working in that language. + + The "System Libraries" of an executable work include anything, other +than the work as a whole, that (a) is included in the normal form of +packaging a Major Component, but which is not part of that Major +Component, and (b) serves only to enable use of the work with that +Major Component, or to implement a Standard Interface for which an +implementation is available to the public in source code form. A +"Major Component", in this context, means a major essential component +(kernel, window system, and so on) of the specific operating system +(if any) on which the executable work runs, or a compiler used to +produce the work, or an object code interpreter used to run it. + + The "Corresponding Source" for a work in object code form means all +the source code needed to generate, install, and (for an executable +work) run the object code and to modify the work, including scripts to +control those activities. However, it does not include the work's +System Libraries, or general-purpose tools or generally available free +programs which are used unmodified in performing those activities but +which are not part of the work. For example, Corresponding Source +includes interface definition files associated with source files for +the work, and the source code for shared libraries and dynamically +linked subprograms that the work is specifically designed to require, +such as by intimate data communication or control flow between those +subprograms and other parts of the work. + + The Corresponding Source need not include anything that users +can regenerate automatically from other parts of the Corresponding +Source. + + The Corresponding Source for a work in source code form is that +same work. + + 2. Basic Permissions. + + All rights granted under this License are granted for the term of +copyright on the Program, and are irrevocable provided the stated +conditions are met. This License explicitly affirms your unlimited +permission to run the unmodified Program. The output from running a +covered work is covered by this License only if the output, given its +content, constitutes a covered work. This License acknowledges your +rights of fair use or other equivalent, as provided by copyright law. + + You may make, run and propagate covered works that you do not +convey, without conditions so long as your license otherwise remains +in force. You may convey covered works to others for the sole purpose +of having them make modifications exclusively for you, or provide you +with facilities for running those works, provided that you comply with +the terms of this License in conveying all material for which you do +not control copyright. Those thus making or running the covered works +for you must do so exclusively on your behalf, under your direction +and control, on terms that prohibit them from making any copies of +your copyrighted material outside their relationship with you. + + Conveying under any other circumstances is permitted solely under +the conditions stated below. Sublicensing is not allowed; section 10 +makes it unnecessary. + + 3. Protecting Users' Legal Rights From Anti-Circumvention Law. + + No covered work shall be deemed part of an effective technological +measure under any applicable law fulfilling obligations under article +11 of the WIPO copyright treaty adopted on 20 December 1996, or +similar laws prohibiting or restricting circumvention of such +measures. + + When you convey a covered work, you waive any legal power to forbid +circumvention of technological measures to the extent such circumvention +is effected by exercising rights under this License with respect to +the covered work, and you disclaim any intention to limit operation or +modification of the work as a means of enforcing, against the work's +users, your or third parties' legal rights to forbid circumvention of +technological measures. + + 4. Conveying Verbatim Copies. + + You may convey verbatim copies of the Program's source code as you +receive it, in any medium, provided that you conspicuously and +appropriately publish on each copy an appropriate copyright notice; +keep intact all notices stating that this License and any +non-permissive terms added in accord with section 7 apply to the code; +keep intact all notices of the absence of any warranty; and give all +recipients a copy of this License along with the Program. + + You may charge any price or no price for each copy that you convey, +and you may offer support or warranty protection for a fee. + + 5. Conveying Modified Source Versions. + + You may convey a work based on the Program, or the modifications to +produce it from the Program, in the form of source code under the +terms of section 4, provided that you also meet all of these conditions: + + a) The work must carry prominent notices stating that you modified + it, and giving a relevant date. + + b) The work must carry prominent notices stating that it is + released under this License and any conditions added under section + 7. This requirement modifies the requirement in section 4 to + "keep intact all notices". + + c) You must license the entire work, as a whole, under this + License to anyone who comes into possession of a copy. This + License will therefore apply, along with any applicable section 7 + additional terms, to the whole of the work, and all its parts, + regardless of how they are packaged. This License gives no + permission to license the work in any other way, but it does not + invalidate such permission if you have separately received it. + + d) If the work has interactive user interfaces, each must display + Appropriate Legal Notices; however, if the Program has interactive + interfaces that do not display Appropriate Legal Notices, your + work need not make them do so. + + A compilation of a covered work with other separate and independent +works, which are not by their nature extensions of the covered work, +and which are not combined with it such as to form a larger program, +in or on a volume of a storage or distribution medium, is called an +"aggregate" if the compilation and its resulting copyright are not +used to limit the access or legal rights of the compilation's users +beyond what the individual works permit. Inclusion of a covered work +in an aggregate does not cause this License to apply to the other +parts of the aggregate. + + 6. Conveying Non-Source Forms. + + You may convey a covered work in object code form under the terms +of sections 4 and 5, provided that you also convey the +machine-readable Corresponding Source under the terms of this License, +in one of these ways: + + a) Convey the object code in, or embodied in, a physical product + (including a physical distribution medium), accompanied by the + Corresponding Source fixed on a durable physical medium + customarily used for software interchange. + + b) Convey the object code in, or embodied in, a physical product + (including a physical distribution medium), accompanied by a + written offer, valid for at least three years and valid for as + long as you offer spare parts or customer support for that product + model, to give anyone who possesses the object code either (1) a + copy of the Corresponding Source for all the software in the + product that is covered by this License, on a durable physical + medium customarily used for software interchange, for a price no + more than your reasonable cost of physically performing this + conveying of source, or (2) access to copy the + Corresponding Source from a network server at no charge. + + c) Convey individual copies of the object code with a copy of the + written offer to provide the Corresponding Source. This + alternative is allowed only occasionally and noncommercially, and + only if you received the object code with such an offer, in accord + with subsection 6b. + + d) Convey the object code by offering access from a designated + place (gratis or for a charge), and offer equivalent access to the + Corresponding Source in the same way through the same place at no + further charge. You need not require recipients to copy the + Corresponding Source along with the object code. If the place to + copy the object code is a network server, the Corresponding Source + may be on a different server (operated by you or a third party) + that supports equivalent copying facilities, provided you maintain + clear directions next to the object code saying where to find the + Corresponding Source. Regardless of what server hosts the + Corresponding Source, you remain obligated to ensure that it is + available for as long as needed to satisfy these requirements. + + e) Convey the object code using peer-to-peer transmission, provided + you inform other peers where the object code and Corresponding + Source of the work are being offered to the general public at no + charge under subsection 6d. + + A separable portion of the object code, whose source code is excluded +from the Corresponding Source as a System Library, need not be +included in conveying the object code work. + + A "User Product" is either (1) a "consumer product", which means any +tangible personal property which is normally used for personal, family, +or household purposes, or (2) anything designed or sold for incorporation +into a dwelling. In determining whether a product is a consumer product, +doubtful cases shall be resolved in favor of coverage. For a particular +product received by a particular user, "normally used" refers to a +typical or common use of that class of product, regardless of the status +of the particular user or of the way in which the particular user +actually uses, or expects or is expected to use, the product. A product +is a consumer product regardless of whether the product has substantial +commercial, industrial or non-consumer uses, unless such uses represent +the only significant mode of use of the product. + + "Installation Information" for a User Product means any methods, +procedures, authorization keys, or other information required to install +and execute modified versions of a covered work in that User Product from +a modified version of its Corresponding Source. The information must +suffice to ensure that the continued functioning of the modified object +code is in no case prevented or interfered with solely because +modification has been made. + + If you convey an object code work under this section in, or with, or +specifically for use in, a User Product, and the conveying occurs as +part of a transaction in which the right of possession and use of the +User Product is transferred to the recipient in perpetuity or for a +fixed term (regardless of how the transaction is characterized), the +Corresponding Source conveyed under this section must be accompanied +by the Installation Information. But this requirement does not apply +if neither you nor any third party retains the ability to install +modified object code on the User Product (for example, the work has +been installed in ROM). + + The requirement to provide Installation Information does not include a +requirement to continue to provide support service, warranty, or updates +for a work that has been modified or installed by the recipient, or for +the User Product in which it has been modified or installed. Access to a +network may be denied when the modification itself materially and +adversely affects the operation of the network or violates the rules and +protocols for communication across the network. + + Corresponding Source conveyed, and Installation Information provided, +in accord with this section must be in a format that is publicly +documented (and with an implementation available to the public in +source code form), and must require no special password or key for +unpacking, reading or copying. + + 7. Additional Terms. + + "Additional permissions" are terms that supplement the terms of this +License by making exceptions from one or more of its conditions. +Additional permissions that are applicable to the entire Program shall +be treated as though they were included in this License, to the extent +that they are valid under applicable law. If additional permissions +apply only to part of the Program, that part may be used separately +under those permissions, but the entire Program remains governed by +this License without regard to the additional permissions. + + When you convey a copy of a covered work, you may at your option +remove any additional permissions from that copy, or from any part of +it. (Additional permissions may be written to require their own +removal in certain cases when you modify the work.) You may place +additional permissions on material, added by you to a covered work, +for which you have or can give appropriate copyright permission. + + Notwithstanding any other provision of this License, for material you +add to a covered work, you may (if authorized by the copyright holders of +that material) supplement the terms of this License with terms: + + a) Disclaiming warranty or limiting liability differently from the + terms of sections 15 and 16 of this License; or + + b) Requiring preservation of specified reasonable legal notices or + author attributions in that material or in the Appropriate Legal + Notices displayed by works containing it; or + + c) Prohibiting misrepresentation of the origin of that material, or + requiring that modified versions of such material be marked in + reasonable ways as different from the original version; or + + d) Limiting the use for publicity purposes of names of licensors or + authors of the material; or + + e) Declining to grant rights under trademark law for use of some + trade names, trademarks, or service marks; or + + f) Requiring indemnification of licensors and authors of that + material by anyone who conveys the material (or modified versions of + it) with contractual assumptions of liability to the recipient, for + any liability that these contractual assumptions directly impose on + those licensors and authors. + + All other non-permissive additional terms are considered "further +restrictions" within the meaning of section 10. If the Program as you +received it, or any part of it, contains a notice stating that it is +governed by this License along with a term that is a further +restriction, you may remove that term. If a license document contains +a further restriction but permits relicensing or conveying under this +License, you may add to a covered work material governed by the terms +of that license document, provided that the further restriction does +not survive such relicensing or conveying. + + If you add terms to a covered work in accord with this section, you +must place, in the relevant source files, a statement of the +additional terms that apply to those files, or a notice indicating +where to find the applicable terms. + + Additional terms, permissive or non-permissive, may be stated in the +form of a separately written license, or stated as exceptions; +the above requirements apply either way. + + 8. Termination. + + You may not propagate or modify a covered work except as expressly +provided under this License. Any attempt otherwise to propagate or +modify it is void, and will automatically terminate your rights under +this License (including any patent licenses granted under the third +paragraph of section 11). + + However, if you cease all violation of this License, then your +license from a particular copyright holder is reinstated (a) +provisionally, unless and until the copyright holder explicitly and +finally terminates your license, and (b) permanently, if the copyright +holder fails to notify you of the violation by some reasonable means +prior to 60 days after the cessation. + + Moreover, your license from a particular copyright holder is +reinstated permanently if the copyright holder notifies you of the +violation by some reasonable means, this is the first time you have +received notice of violation of this License (for any work) from that +copyright holder, and you cure the violation prior to 30 days after +your receipt of the notice. + + Termination of your rights under this section does not terminate the +licenses of parties who have received copies or rights from you under +this License. If your rights have been terminated and not permanently +reinstated, you do not qualify to receive new licenses for the same +material under section 10. + + 9. Acceptance Not Required for Having Copies. + + You are not required to accept this License in order to receive or +run a copy of the Program. Ancillary propagation of a covered work +occurring solely as a consequence of using peer-to-peer transmission +to receive a copy likewise does not require acceptance. However, +nothing other than this License grants you permission to propagate or +modify any covered work. These actions infringe copyright if you do +not accept this License. Therefore, by modifying or propagating a +covered work, you indicate your acceptance of this License to do so. + + 10. Automatic Licensing of Downstream Recipients. + + Each time you convey a covered work, the recipient automatically +receives a license from the original licensors, to run, modify and +propagate that work, subject to this License. You are not responsible +for enforcing compliance by third parties with this License. + + An "entity transaction" is a transaction transferring control of an +organization, or substantially all assets of one, or subdividing an +organization, or merging organizations. If propagation of a covered +work results from an entity transaction, each party to that +transaction who receives a copy of the work also receives whatever +licenses to the work the party's predecessor in interest had or could +give under the previous paragraph, plus a right to possession of the +Corresponding Source of the work from the predecessor in interest, if +the predecessor has it or can get it with reasonable efforts. + + You may not impose any further restrictions on the exercise of the +rights granted or affirmed under this License. For example, you may +not impose a license fee, royalty, or other charge for exercise of +rights granted under this License, and you may not initiate litigation +(including a cross-claim or counterclaim in a lawsuit) alleging that +any patent claim is infringed by making, using, selling, offering for +sale, or importing the Program or any portion of it. + + 11. Patents. + + A "contributor" is a copyright holder who authorizes use under this +License of the Program or a work on which the Program is based. The +work thus licensed is called the contributor's "contributor version". + + A contributor's "essential patent claims" are all patent claims +owned or controlled by the contributor, whether already acquired or +hereafter acquired, that would be infringed by some manner, permitted +by this License, of making, using, or selling its contributor version, +but do not include claims that would be infringed only as a +consequence of further modification of the contributor version. For +purposes of this definition, "control" includes the right to grant +patent sublicenses in a manner consistent with the requirements of +this License. + + Each contributor grants you a non-exclusive, worldwide, royalty-free +patent license under the contributor's essential patent claims, to +make, use, sell, offer for sale, import and otherwise run, modify and +propagate the contents of its contributor version. + + In the following three paragraphs, a "patent license" is any express +agreement or commitment, however denominated, not to enforce a patent +(such as an express permission to practice a patent or covenant not to +sue for patent infringement). To "grant" such a patent license to a +party means to make such an agreement or commitment not to enforce a +patent against the party. + + If you convey a covered work, knowingly relying on a patent license, +and the Corresponding Source of the work is not available for anyone +to copy, free of charge and under the terms of this License, through a +publicly available network server or other readily accessible means, +then you must either (1) cause the Corresponding Source to be so +available, or (2) arrange to deprive yourself of the benefit of the +patent license for this particular work, or (3) arrange, in a manner +consistent with the requirements of this License, to extend the patent +license to downstream recipients. "Knowingly relying" means you have +actual knowledge that, but for the patent license, your conveying the +covered work in a country, or your recipient's use of the covered work +in a country, would infringe one or more identifiable patents in that +country that you have reason to believe are valid. + + If, pursuant to or in connection with a single transaction or +arrangement, you convey, or propagate by procuring conveyance of, a +covered work, and grant a patent license to some of the parties +receiving the covered work authorizing them to use, propagate, modify +or convey a specific copy of the covered work, then the patent license +you grant is automatically extended to all recipients of the covered +work and works based on it. + + A patent license is "discriminatory" if it does not include within +the scope of its coverage, prohibits the exercise of, or is +conditioned on the non-exercise of one or more of the rights that are +specifically granted under this License. You may not convey a covered +work if you are a party to an arrangement with a third party that is +in the business of distributing software, under which you make payment +to the third party based on the extent of your activity of conveying +the work, and under which the third party grants, to any of the +parties who would receive the covered work from you, a discriminatory +patent license (a) in connection with copies of the covered work +conveyed by you (or copies made from those copies), or (b) primarily +for and in connection with specific products or compilations that +contain the covered work, unless you entered into that arrangement, +or that patent license was granted, prior to 28 March 2007. + + Nothing in this License shall be construed as excluding or limiting +any implied license or other defenses to infringement that may +otherwise be available to you under applicable patent law. + + 12. No Surrender of Others' Freedom. + + If conditions are imposed on you (whether by court order, agreement or +otherwise) that contradict the conditions of this License, they do not +excuse you from the conditions of this License. If you cannot convey a +covered work so as to satisfy simultaneously your obligations under this +License and any other pertinent obligations, then as a consequence you may +not convey it at all. For example, if you agree to terms that obligate you +to collect a royalty for further conveying from those to whom you convey +the Program, the only way you could satisfy both those terms and this +License would be to refrain entirely from conveying the Program. + + 13. Use with the GNU Affero General Public License. + + Notwithstanding any other provision of this License, you have +permission to link or combine any covered work with a work licensed +under version 3 of the GNU Affero General Public License into a single +combined work, and to convey the resulting work. The terms of this +License will continue to apply to the part which is the covered work, +but the special requirements of the GNU Affero General Public License, +section 13, concerning interaction through a network will apply to the +combination as such. + + 14. Revised Versions of this License. + + The Free Software Foundation may publish revised and/or new versions of +the GNU General Public License from time to time. Such new versions will +be similar in spirit to the present version, but may differ in detail to +address new problems or concerns. + + Each version is given a distinguishing version number. If the +Program specifies that a certain numbered version of the GNU General +Public License "or any later version" applies to it, you have the +option of following the terms and conditions either of that numbered +version or of any later version published by the Free Software +Foundation. If the Program does not specify a version number of the +GNU General Public License, you may choose any version ever published +by the Free Software Foundation. + + If the Program specifies that a proxy can decide which future +versions of the GNU General Public License can be used, that proxy's +public statement of acceptance of a version permanently authorizes you +to choose that version for the Program. + + Later license versions may give you additional or different +permissions. However, no additional obligations are imposed on any +author or copyright holder as a result of your choosing to follow a +later version. + + 15. Disclaimer of Warranty. + + THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY +APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT +HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY +OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, +THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM +IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF +ALL NECESSARY SERVICING, REPAIR OR CORRECTION. + + 16. Limitation of Liability. + + IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING +WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS +THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY +GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE +USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF +DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD +PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), +EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF +SUCH DAMAGES. + + 17. Interpretation of Sections 15 and 16. + + If the disclaimer of warranty and limitation of liability provided +above cannot be given local legal effect according to their terms, +reviewing courts shall apply local law that most closely approximates +an absolute waiver of all civil liability in connection with the +Program, unless a warranty or assumption of liability accompanies a +copy of the Program in return for a fee. + + END OF TERMS AND CONDITIONS + + How to Apply These Terms to Your New Programs + + If you develop a new program, and you want it to be of the greatest +possible use to the public, the best way to achieve this is to make it +free software which everyone can redistribute and change under these terms. + + To do so, attach the following notices to the program. It is safest +to attach them to the start of each source file to most effectively +state the exclusion of warranty; and each file should have at least +the "copyright" line and a pointer to where the full notice is found. + + + Copyright (C) + + This program is free software: you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation, either version 3 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program. If not, see . + +Also add information on how to contact you by electronic and paper mail. + + If the program does terminal interaction, make it output a short +notice like this when it starts in an interactive mode: + + Copyright (C) + This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'. + This is free software, and you are welcome to redistribute it + under certain conditions; type `show c' for details. + +The hypothetical commands `show w' and `show c' should show the appropriate +parts of the General Public License. Of course, your program's commands +might be different; for a GUI interface, you would use an "about box". + + You should also get your employer (if you work as a programmer) or school, +if any, to sign a "copyright disclaimer" for the program, if necessary. +For more information on this, and how to apply and follow the GNU GPL, see +. + + The GNU General Public License does not permit incorporating your program +into proprietary programs. If your program is a subroutine library, you +may consider it more useful to permit linking proprietary applications with +the library. If this is what you want to do, use the GNU Lesser General +Public License instead of this License. But first, please read +. + diff --git a/Makefile b/Makefile new file mode 100644 --- /dev/null +++ b/Makefile @@ -0,0 +1,84 @@ +GHCIFLAGS = -XForeignFunctionInterface -lxfconf-0 -idist/build/ +PROFDIR = Prof + +### Artificial Makefile dependencies tree ############################# + +DISTDIR = ./dist +SOURCES = $(wildcard System/XFCE/Xfconf/*.chs Tests/*.hs) +BUILDDIR = $(DISTDIR)/build +_MYBIN = $(BUILDDIR)/tests/tests $(BUILDDIR)/testGlib/testGlib +_MYDOC = $(DISTDIR)/doc/html/xfconf/index.html + +### Cabal frontend #################################################### + +all: build + +configure: | $(DISTDIR) +$(DISTDIR): xfconf.cabal + cabal configure -f "buildTests" --ghc-options="-prof -rtsopts=all" + +build: $(_MYBIN) +$(_MYBIN): $(SOURCES) | configure + cabal build + +.PHONY: clean +clean: + cabal clean + rm -fr $(PROFDIR) + +docs doc: $(_MYDOC) +$(_MYDOC): $(SOURCES) | configure + cabal haddock + +.PHONY: doc_view +doc_view: $(_MYDOC) + xdg-open $^ + +### Debug helpers ##################################################### + +.PHONY: debug +debug: build + ghci $(GHCIFLAGS) System/XFCE/Xfconf.hs; + +.PHONY: debugTest +debugTest: build + ghci $(GHCIFLAGS) Tests/Tests.hs; + +.PHONY: debugGlib +debugGlib: build + ghci $(GHCIFLAGS) Tests/TestGlib.hs; + +.PHONY: debugDemo +debugDemo: build + ghci $(GHCIFLAGS) Demo/Demo.hs; + +### Launch pre-configured tests ####################################### + +.PHONY: watch +watch: + watch xfconf-query -c quickcheck -vl + +.PHONY: tests test +tests test: $(_MYBIN) + $(BUILDDIR)/tests/tests --maximum-generated-tests=500 -j3 + +.PHONY: testGlib +testGlib: $(_MYBIN) + $(BUILDDIR)/testGlib/testGlib + +.PHONY: demo +demo: build + runghc Demo/Demo.hs + +### Profiling ######################################################### + +Prof/tests.prof: + rm -fr $(PROFDIR) && mkdir -p $(PROFDIR) + ( cd $(PROFDIR)\ + ; ../$(BUILDDIR)/tests/tests --maximum-generated-tests=500 -j3 +RTS -p -hc -sstderr\ + ; hp2ps -c tests.hp ) + +profiling: Prof/tests.prof + ( cd $(PROFDIR)\ + ; xdg-open tests.ps 2>&1 1>/dev/null\ + ; less tests.prof ) diff --git a/README b/README new file mode 100644 --- /dev/null +++ b/README @@ -0,0 +1,70 @@ +Summary +======= + +Haskell bindings to XFCE 4.8 xfconf settings daemon. + +Original xfconf API documentation can be found on: + http://docs.xfce.org/api/xfconf/ + +Requirement +=========== + +GHC and xfconf-devel/libxfconf obviously :) + +You will need a fairly new version of haddock too (>= 2.8). + +Cabal should take care of the rest. + +Status +====== + +Presently, the whole thing is (almost) no more hackish. The system was +integrated with cabal, a set of QuickCheck tests prove the storing and +retrieving of large data sets to work properly and the XfconfChannel* +objects inherit from regular gtk2hs-glib.GObjects. + +Only Tests/TestGlib.hs appears broken. + +Example +======= + +An application of this library can be found with hThemes[0], a small +utility to quickly save and load pre-configured xfconf settings (notably +wallpapers, gtk+2 & xfwm4 themes). + +[0]: https://patch-tag.com/r/obbele/hThemes/home + +How to build +============ + +Just try this: + + bash $ make # shortcut for cabal configure -f buildTests + # and cabal build + +How to use the Tests/*.hs binaries +================================== + +Those tests require a working version of XFCE >= 4.8, as well as the +haskell packages test-framework, test-framework-hunit, HUnit, +test-framework-quickcheck2 and QuickCheck. The demo program requires the +haskell binding for gtk. You can ask cabal to build it for you by +specifying the flag "buildTests": + + bash $ cabal configure -fbuildTests + bash $ cabal build + bash $ ./dist/build/tests/tests + bash $ ./dist/build/testGlib/testGlib + bash $ runghc Demo/Demo.hs + +Or you can just quickly run them with one of the following shortcuts: + + bash $ make test(s) # run with 500 test samples + bash $ make testGlib # test glib signals + # (need a -threaded binary) + bash $ make demo # run the small xfconf bindings demo + +You're welcomed to report any suggestions / bug reports to john obbele +AT gmail. + +© Copyright 2010-2011 John Obbele. All Rights Reserved. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,7 @@ +-- Setup file for a Gtk2Hs module. Contains only adjustments specific to this module, +-- all Gtk2Hs-specific boilerplate is stored in Gtk2HsSetup.hs which should be kept +-- identical across all modules. +import Gtk2HsSetup ( gtk2hsUserHooks ) +import Distribution.Simple ( defaultMainWithHooks ) + +main = defaultMainWithHooks gtk2hsUserHooks diff --git a/System/XFCE/Xfconf.hs b/System/XFCE/Xfconf.hs new file mode 100644 --- /dev/null +++ b/System/XFCE/Xfconf.hs @@ -0,0 +1,13 @@ +module System.XFCE.Xfconf ( + module System.XFCE.Xfconf.Core, + module System.XFCE.Xfconf.Error, + module System.XFCE.Xfconf.Values, + module System.XFCE.Xfconf.Channel, + module System.XFCE.Xfconf.Binding +) where + +import System.XFCE.Xfconf.Core +import System.XFCE.Xfconf.Error +import System.XFCE.Xfconf.Values +import System.XFCE.Xfconf.Channel +import System.XFCE.Xfconf.Binding diff --git a/System/XFCE/Xfconf/Binding.chs b/System/XFCE/Xfconf/Binding.chs new file mode 100644 --- /dev/null +++ b/System/XFCE/Xfconf/Binding.chs @@ -0,0 +1,212 @@ +{-# LANGUAGE CPP, ForeignFunctionInterface #-} +-- -*-haskell-*- +-- + +{- | Xfconf-GObject Binding -- Functions to bind Xfconf properties to + GObject properties. + + Note that this haskell API follows closely the original C API. Object + properties should be given using their string name from the C API + and not their Haskell name deriving from + 'System.Glib.Attributes.ReadWriteAttr'. + + For more information, see: + http:\/\/docs.xfce.org\/api\/xfconf\/xfconf-xfconf-binding.html +-} + + +#include +#include + +{# context lib="xfconf-0" prefix="xfconf" #} + +module System.XFCE.Xfconf.Binding ( + -- * Detail + -- $details + + -- * Example + -- $example + + -- * Types + XfconfBindingID, + + -- * Functions + xfconfBind, + xfconfBindGdkColor, + xfconfUnbind, + xfconfUnbindAll, + xfconfUnbindByProperty, + + -- re-exports glib gtype constants + module System.Glib.GTypeConstants + + ) where + +import System.Glib.GObject (GObject(GObject), GObjectClass(toGObject)) +import System.Glib.GType (GType) +import System.Glib.GTypeConstants +import System.Glib.UTFString + +import System.XFCE.Xfconf.FFI +{#import System.XFCE.Xfconf.Types #} + +{---------------------------------------------------------------------- +-- Details +----------------------------------------------------------------------} + +-- $details +-- Often it may be useful to bind an Xfconf property to a GObject +-- property. Settings dialogs often display the current value of an +-- Xfconf property, and a user may edit the value to change the value in +-- the Xfconf store. If the Xfconf property changes outside the settings +-- dialog, the user will usually want to see the settings dialog +-- automatically update to reflect the new value. With a single line +-- of code, Xfconf's binding functionality can automate all this. + +{---------------------------------------------------------------------- +-- Example (from Tests/Demo.hs) +----------------------------------------------------------------------} + +-- $example +-- From the demo program in @\"Tests/Demo.hs\"@ +-- +-- @ +-- chan \<- channelGet \"Demo\" +-- -- +-- check0 \<- checkButtonNewWithLabel \"Check me \!\" +-- label0 \<- labelNew (Just \"\\") +-- check1 \<- checkButtonNewWithLabel \"Check me !\" +-- -- +-- let xfconf_property = \"\/check\" +-- \ \ \ \ obj_property = \"active\" -- toggleButtonActive attribute +-- -- +-- -- Signals voodoo \\o\/ +-- -- * bind check buttons from\/to xfconfd +-- -- * thus, their \"active\" state will remain synchronized +-- xfsig0 \<- xfconfBind chan xfconf_property bool check0 obj_property +-- xfsig1 \<- xfconfBind chan xfconf_property bool check1 obj_property +-- -- +-- -- * monitor xfconfd and update the label accordingly +-- onPropertyChanged chan $ \\key maybeValue -> do +-- \ \ if key \/= xfconf_property +-- \ \ \ then return () +-- \ \ \ else case maybeValue of +-- \ \ \ \ \ Just (XfconfBool True) -> labelSetText label0 \"checked !\" +-- \ \ \ \ \ Just (XfconfBool False) -> labelSetText label0 \"unchecked !\" +-- \ \ \ \ \ _ -> labelSetText label0 \"UNKNOWN\" +-- -- +-- -- Who cares about memory management nowadays ? +-- onDestroy window $ do +-- \ \ \ \ \ \ \ \ mainQuit +-- \ \ \ \ \ \ \ \ putStrLn \"ByeBye\" +-- @ + +{---------------------------------------------------------------------- +-- Types and marshallers +----------------------------------------------------------------------} + +-- | ID number that can be used to later remove corresponding bindings. +newtype XfconfBindingID = XfconfBindingID {unXfconfBindingID :: CULong} + +-- | convenient marshall in function +withGObject :: GObjectClass obj => obj -> (Ptr () -> IO b) -> IO b +withGObject obj = let (GObject ptr) = toGObject obj + in withForeignPtr (castForeignPtr ptr) + +{---------------------------------------------------------------------- +-- Bindings +----------------------------------------------------------------------} + +-- | Binds an Xfconf property to a GObject property. If the property is +-- changed via either the GObject or Xfconf, the corresponding property +-- will also be updated. +-- +-- Note that @xfconf property type@ is required since @xfconf property@ +-- may or may not already exist in the Xfconf store. The type of @object +-- property@ will be determined automatically. If the two types do not +-- match, a conversion will be attempted. +xfconfBind :: (XfconfChannelClass conf, GObjectClass obj) + => conf -- ^ channel + -> String -- ^ xfconf property + -> GType -- ^ xfconf property type + -> obj -- ^ object + -> String -- ^ object property + -> IO XfconfBindingID -- ^ Xfconf binding ID +xfconfBind chan0 prop1 type2 obj3 prop4 = + withUTFString prop1 $ \prop1' -> + withGObject obj3 $ \obj3' -> + withUTFString prop4 $ \prop4' -> + let chan0' = toXfconfChannel chan0 + f = {#call unsafe g_property_bind #} + in XfconfBindingID `fmap` f chan0' prop1' type2 obj3' prop4' + +-- | Binds an Xfconf property to a GObject property of type +-- GDK_TYPE_COLOR (aka a GdkColor struct or simply 'Color' in Haskell +-- Pango library). If the property is changed via either the GObject or +-- Xfconf, the corresponding property will also be updated. +-- +-- This is a special-case binding; the GdkColor struct is not ideal +-- as-is for binding to a property, so it is stored in the Xfconf store +-- as four 16-bit unsigned ints (red, green, blue, alpha). Since +-- GdkColor (currently) only supports RGB and not RGBA, the last value +-- will always be set to 0xFFFF. +xfconfBindGdkColor :: (XfconfChannelClass conf, GObjectClass obj) + => conf -- ^ channel + -> String -- ^ xfconf property + -> obj -- ^ object + -> String -- ^ object property + -> IO XfconfBindingID +xfconfBindGdkColor chan0 prop1 obj2 prop3 = + withUTFString prop1 $ \prop1' -> + withGObject obj2 $ \obj2' -> + withUTFString prop3 $ \prop3' -> + let chan0' = toXfconfChannel chan0 + f = {#call unsafe g_property_bind_gdkcolor #} + in XfconfBindingID `fmap` f chan0' prop1' obj2' prop3' + +-- | Removes an Xfconf/GObject property binding based on the binding +-- 'XfconfBindingID' number. See 'xfconfBind'. +xfconfUnbind :: XfconfBindingID -> IO () +xfconfUnbind = {#call unsafe g_property_unbind #} . unXfconfBindingID + +-- | Causes an Xfconf channel previously bound to a GObject property +-- (see 'xfconfBind') to no longer be bound. +xfconfUnbindByProperty :: (XfconfChannelClass conf, GObjectClass obj) + => conf -- ^ channel + -> String -- ^ channel property + -> obj -- ^ object + -> String -- ^ object property + -> IO () +xfconfUnbindByProperty conf0 prop1 obj2 prop3 = + withUTFString prop1 $ \prop1' -> + withGObject obj2 $ \obj2' -> + withUTFString prop3 $ \prop3' -> + let conf0' = toXfconfChannel conf0 + f = {#call unsafe g_property_unbind_by_property #} + in f conf0' prop1' obj2' prop3' + +-- | Unbinds all Xfconf channel bindings (see 'xfconfBind') +-- to object. If object is an 'XfconfChannel', it will unbind all xfconf +-- properties on that channel. If object is a regular 'GObject' with +-- properties bound to a channel, all those bindings will be removed. +xfconfUnbindAll :: GObjectClass obj => obj -> IO () +xfconfUnbindAll entity = withGObject entity unbind + where unbind ptr = {#call unsafe g_property_unbind_all #} (castPtr ptr) + +{---------------------------------------------------------------------- +-- TODO + +- xfconf-binding.h function list +- +- > bash $ sed '/^\(\/\| \*\|#\)/d' xfconf-binding.h | grep '(' +- + +DEMO xfconf_g_property_bind +DONE xfconf_g_property_bind_gdkcolor +DEMO xfconf_g_property_unbind +DEMO xfconf_g_property_unbind_all +DEMO xfconf_g_property_unbind_by_property + +----------------------------------------------------------------------} + +-- vim:filetype=haskell: diff --git a/System/XFCE/Xfconf/Channel.chs b/System/XFCE/Xfconf/Channel.chs new file mode 100644 --- /dev/null +++ b/System/XFCE/Xfconf/Channel.chs @@ -0,0 +1,808 @@ +{-# LANGUAGE CPP, ForeignFunctionInterface #-} +-- -*-haskell-*- +-- +-- XXX: Property names are considered to be encoded in UTF-8 too +-- (string values are already encoded to / decoded from UTF-8). + + +{- | An application-defined domain for storing configuration settings. + + For more information, see: + http:\/\/docs.xfce.org\/api\/xfconf\/xfconf-xfconf-channel.html +-} + + +#include + +{# context lib="xfconf-0" prefix="xfconf" #} + +module System.XFCE.Xfconf.Channel ( + -- * Detail + -- $detail + + -- * Example + -- $example + + -- * Class Hierarchy + -- $classHierarchy + + -- * Channel Type + -- re-exported from "System.XFCE.Xfconf.Types" + XfconfChannelClass, + XfconfChannel, + + -- * Constructors + channelGet, + channelNew, + channelNewWithPropertyBase, + + -- * Attributes + -- | The name of the channel. + channelGetName, + channelName, + -- | Base property path. + channelGetPropertyBase, + channelPropertyBase, + -- | re-exported from "System.Glib.Attributes" + get, + + -- * Signals + onPropertyChanged, + afterPropertyChanged, + propertyChanged, + + -- * Methods + -- ** Misc + channelHasProperty, + channelIsPropertyLocked, + channelResetProperty, + channelGetKeys, + channelGetAllKeys, + + -- ** Basic values get/set + -- $basicValues + channelGetStringWithDefault, + channelGetString, + channelSetString, + channelGetIntWithDefault, + channelGetInt, + channelSetInt, + channelGetUIntWithDefault, + channelGetUInt, + channelSetUInt, + channelGetUInt64WithDefault, + channelGetUInt64, + channelSetUInt64, + channelGetDoubleWithDefault, + channelGetDouble, + channelSetDouble, + channelGetBoolWithDefault, + channelGetBool, + channelSetBool, + + -- ** Special Xfconf value + -- $special16bits + channelGetUInt16WithDefault, + channelGetUInt16, + channelSetUInt16, + channelGetInt16WithDefault, + channelGetInt16, + channelSetInt16, + + -- ** Complex values get/set + -- $complexValues + channelSetStringList, + channelGetStringList, + channelSetArray, + channelGetArray, + channelGetProperty, + channelSetProperty, + channelGetAllProperties, + channelGetProperties, + channelSetProperties + + ) where + +import Control.Monad (when) +import Data.Char (toLower) +import qualified Foreign.Concurrent as FC + +import System.Glib.GValue +import System.Glib.Attributes (ReadAttr, readAttr, get) +import System.Glib.Properties (objectGetPropertyString) +import System.Glib.GTypeConstants (bool, invalid) +import System.Glib.UTFString + +import System.XFCE.Xfconf.FFI +{#import System.XFCE.Xfconf.Types #} +{#import System.XFCE.Xfconf.Signals #} +{#import System.XFCE.Xfconf.Unsafe #} +{#import System.XFCE.Xfconf.Values #} +{#import System.XFCE.Xfconf.GHashTable #} + +{---------------------------------------------------------------------- +-- Documentation +----------------------------------------------------------------------} + +-- $detail +-- An XfconfChannel is a representation of a restricted domain or +-- namespace that an application can define to store configuration +-- settings. This is to ensure that different applications do not store +-- configuration keys with the same names. + +-- $example +-- Channel initialisation: +-- +-- @ +-- chan \<- channelGet \"demo\" +-- -- +-- -- Clear channel +-- channelResetProperty chan \"\/\" True +-- -- +-- channelSetInt chan \"\/MyInt\" 42 +-- channelSetString chan \"\/MyString\" \"Hello world\" +-- channelSetStringList chan \"\/MyList\" \[ \"haskell\", \"xfce\", \"xfconf\", \"gtk\" \] +-- channelSetProperty chan \"\/MyArray\" (Just \[1..5\] :: Maybe \[Int\]) +-- @ +-- +-- Which we'll give us: +-- +-- >>> channelGetAllKeys chan >>= mapM_ print +-- "/MyInt" +-- "/MyString" +-- "/MyList" +-- "/MyArray" +-- +-- >>> channelGetAllProperties chan >>= mapM_ print +-- ("/MyInt",Just (XfconfInt 42)) +-- ("/MyString",Just (XfconfString "Hello world")) +-- ("/MyList",Just (XfconfArray [XfconfString "haskell",XfconfString "xfce",XfconfString "xfconf",XfconfString "gtk"])) +-- ("/MyArray",Just (XfconfArray [XfconfInt 1,XfconfInt 2,XfconfInt 3,XfconfInt 4,XfconfInt 5])) + +-- $classHierarchy +-- @ +-- | 'GObject' +-- | +-----'XfconfChannel' +-- @ + +{---------------------------------------------------------------------- +-- Types and constructors +----------------------------------------------------------------------} + +foreign import ccall unsafe "g_object_unref" + g_object_unref :: Ptr XfconfChannel -> IO () + +xfconfFinalizer :: Bool -> Ptr XfconfChannel -> IO () +xfconfFinalizer unref ptr = do + when unref (g_object_unref ptr) + xfconfShutdown + +-- | Either creates a new 'Channel', or fetches a singleton object for +-- channel_name. This function always returns a valid object; no +-- checking is done to see if the channel exists or has a valid name. +-- +-- May throw a 'GError', see 'xfconfInit' for more information. +channelGet :: String -- ^ channel name + -> IO XfconfChannel +channelGet name = do + xfconfInit + ptr <- c_channel_get name' + obj <- FC.newForeignPtr ptr (xfconfFinalizer False ptr) + return $! XfconfChannel obj + + -- Xfconf backend does not like upper case characters. + where name' = map toLower name + +{#fun unsafe channel_get as c_channel_get + { withUTFString* `String' -- ^ channel name + } -> `Ptr XfconfChannel' id#} + +-- | Creates a new channel using @name@ as the channel\'s identifier. +-- This function always returns a valid object; no checking is done to +-- see if the channel exists or has a valid name. +-- +-- Note: use of this function is not recommended, in favor of +-- 'channelGet', which returns a singleton object and saves a little +-- memory. However, 'channelNew' can be useful in some cases where you +-- want to tie an 'XfconfChannel' \'s lifetime (and thus the lifetime of +-- connected signals and bound GObject properties) to the lifetime of +-- another object. +-- +-- May throw a 'GError', see 'xfconfInit' for more information. +channelNew :: String -- ^ channel @name@ + -> IO XfconfChannel +channelNew name = do + xfconfInit + objPtr <- c_channel_new name' + obj <- FC.newForeignPtr objPtr (xfconfFinalizer True objPtr) + return $! XfconfChannel obj + + -- Xfconf backend does not like upper case characters. + where name' = map toLower name + +{#fun unsafe channel_new as c_channel_new + { withUTFString* `String' -- ^ channel name + } -> `Ptr XfconfChannel' id#} + +-- | Creates a new channel using @name@ as the channel's identifier, +-- restricting the accessible properties to be rooted at @property_base@. +-- This function always returns a valid object; no checking is done to +-- see if the channel exists or has a valid name. +-- +-- May throw a 'GError', see 'xfconfInit' for more information. +channelNewWithPropertyBase :: String -- ^ channel @name@ + -> String -- ^ root @property_base@ + -> IO XfconfChannel +channelNewWithPropertyBase name prop = do + xfconfInit + objPtr <- c_channel_new_with_property_base name' prop + obj <- FC.newForeignPtr objPtr (xfconfFinalizer True objPtr) + return $! XfconfChannel obj + + -- Xfconf backend does not like upper case characters. + where name' = map toLower name + +{#fun unsafe channel_new_with_property_base as c_channel_new_with_property_base + { withUTFString* `String' -- ^ channel name + , withUTFString* `String' -- ^ property base + } -> `Ptr XfconfChannel' id#} + +{---------------------------------------------------------------------- +-- Utilities +----------------------------------------------------------------------} + +withXfconf :: XfconfChannelClass self + => self -> (Ptr XfconfChannel -> IO b) -> IO b +withXfconf self = let (XfconfChannel ptr) = toXfconfChannel self + in withForeignPtr ptr + +{---------------------------------------------------------------------- +-- Attributes +----------------------------------------------------------------------} + +channelName :: XfconfChannelClass self => ReadAttr self String +channelName = readAttr channelGetName + +channelGetName :: XfconfChannelClass self => self -> IO String +channelGetName = objectGetPropertyString "channel-name" + +channelPropertyBase :: XfconfChannelClass self => ReadAttr self String +channelPropertyBase = readAttr channelGetPropertyBase + +channelGetPropertyBase :: XfconfChannelClass self => self -> IO String +channelGetPropertyBase = objectGetPropertyString "property-base" + +{---------------------------------------------------------------------- +-- Signals +----------------------------------------------------------------------} + +-- | Emitted whenever a property on channel has changed. If the change +-- was caused by the removal of property, value will be unset; you will +-- receive 'Nothing' instead of ('Just' 'XfconfValue'). +-- +propertyChanged :: XfconfChannelClass self + => Signal self (String -> Maybe XfconfValue -> IO ()) +propertyChanged = Signal (connector "property-changed") + where connector name isAfter obj = + connect_STRING_PTR__NONE name isAfter obj . convertHandler + +onPropertyChanged :: XfconfChannelClass self + => self + -> (String -> Maybe XfconfValue -> IO ()) + -> IO (ConnectId self) +onPropertyChanged gc handler = + connect_STRING_PTR__NONE "property-changed" False gc + (convertHandler handler) + +afterPropertyChanged :: XfconfChannelClass self + => self + -> (String -> Maybe XfconfValue -> IO ()) + -> IO (ConnectId self) +afterPropertyChanged gc handler = + connect_STRING_PTR__NONE "property-changed" True gc + (convertHandler handler) + +-- C handler is "Obj -> CString -> Ptr () -> Ptr () -> IO ()" + +-- haskell "pre-marshalled" handler is +-- "String -> Ptr () -> IO ()" + +-- we want to pass a "String -> Maybe XfconfValue -> IO ()" instead + +-- ... hence we convert Ptr GValue to Maybe XfconfValue +convertHandler :: (String -> Maybe XfconfValue -> IO ()) + -> (String -> Ptr () -> IO ()) +convertHandler handler = \key ptr1 -> do + let gvalue = GValue (castPtr ptr1) + gtype <- valueGetType gvalue + if gtype == invalid + then handler key Nothing + else do xvalue <- toXfconfValue gvalue + handler key (Just xvalue) + +{---------------------------------------------------------------------- +-- Methods: misc +----------------------------------------------------------------------} + +-- | Checks to see if property exists on channel. +{#fun unsafe channel_has_property as ^ + `XfconfChannelClass self' => + { withXfconf* `self' -- ^ channel + , withUTFString* `String' -- ^ property + } -> `Bool' toBool #} + +-- | Queries whether or not property on channel is locked by system +-- policy. If the property is locked, calls to 'setProperty' (or any of +-- the \"set\" family of functions) or 'resetProperty' will fail. +{#fun unsafe channel_is_property_locked as ^ + `XfconfChannelClass self' => + { withXfconf* `self' -- ^ channel + , withUTFString* `String' -- ^ property + } -> `Bool' toBool #} + +-- | Resets properties starting at (and including) the 'String' +-- property_base. If recursive is @True@, will also reset all properties +-- that are under property_base in the property hierarchy. +-- +-- A bit of an explanation as to what this function actually does: Since +-- Xfconf backends are expected to support setting defaults via what you +-- might call \"optional schema,\" you can't really \"remove\" +-- properties. Since the client library can't know if a channel +-- provides default values (or even if the backend supports it!), at +-- best it can only reset properties to their default values. To +-- retrieve all properties in the channel, specify \"/\". +{#fun unsafe channel_reset_property as ^ + `XfconfChannelClass self' => + { withXfconf* `self' -- ^ channel + , withUTFString* `String' -- ^ property base + , fromBool `Bool' -- ^ recursive + } -> `()' id#} + +-- | Retrieves the list of properties from 'Channel'. The value of the +-- property specified by the 'String' property_base and all +-- sub-properties are retrieved. To retrieve all properties in the +-- channel, specify \"/\". +channelGetKeys :: XfconfChannelClass self => self -> String -> IO [String] +channelGetKeys chan prop = do + maybeGHT <- c_get_properties chan prop + case maybeGHT of + Nothing -> return [] + Just ght -> gHashTableKeys ght + +-- | Alias to @channelGetKeys channel \"/\"@ +channelGetAllKeys :: XfconfChannelClass self => self -> IO [String] +channelGetAllKeys chan = channelGetKeys chan "/" + +{---------------------------------------------------------------------- +-- Basic values set/get aka the boring stuff + +-- The following functions are a relic of my first FFI, hsc2hs and c2hs +-- experimentation. All the get/set-ters could probably be based on +-- the unique channelGetProperty function. +-- +-- ... and I should probably provide a fromXfconfValue function to ease +-- this operation ... +----------------------------------------------------------------------} + +-- $basicValues +-- The following functions are simple getters\/setters for dead simple +-- glib type (gint, gboolean, gchar*, ...). Set functions come in two +-- flavors: +-- +-- * @getTypeWidthDefault@ takes a third parameter which is the default +-- fallback value returned by xfconf if no value was found +-- +-- * @getType@ are convenience function which returned hard-coded +-- default values. (0 for (u)ints, floats and doubles, \"\" for +-- strings, False for booleans, etc. ) +-- +-- Note that if you wish to \"unset\" a value, you should probably use +-- 'channelResetProperty'. + +--- INT +{#fun unsafe channel_get_int as channelGetIntWithDefault + `XfconfChannelClass self' => + { withXfconf* `self' -- ^ channel pointer + , withUTFString* `String' -- ^ property + , fromIntegral `Int32' -- ^ fallback value + } -> `Int32' fromIntegral #} + +channelGetInt :: XfconfChannelClass self => self -> String -> IO Int32 +channelGetInt chan prop = channelGetIntWithDefault chan prop 0 + +{#fun unsafe channel_set_int as ^ + `XfconfChannelClass self' => + { withXfconf* `self' -- ^ channel pointer + , withUTFString* `String' -- ^ property + , fromIntegral `Int32' -- ^ new value + } -> `Bool' toBool #} + +--- UINT +{#fun unsafe channel_get_uint as channelGetUIntWithDefault + `XfconfChannelClass self' => + { withXfconf* `self' -- ^ channel pointer + , withUTFString* `String' -- ^ property + , fromIntegral `Word32' -- ^ fallback value + } -> `Word32' fromIntegral #} + +channelGetUInt :: XfconfChannelClass self => self -> String -> IO Word32 +channelGetUInt chan prop = channelGetUIntWithDefault chan prop 0 + +{#fun unsafe channel_set_uint as channelSetUInt + `XfconfChannelClass self' => + { withXfconf* `self' -- ^ channel pointer + , withUTFString* `String' -- ^ property + , fromIntegral `Word32' -- ^ new value + } -> `Bool' toBool #} + +--- UINT64 +{#fun unsafe channel_get_uint64 as channelGetUInt64WithDefault + `XfconfChannelClass self' => + { withXfconf* `self' -- ^ channel pointer + , withUTFString* `String' -- ^ property + , fromIntegral `Word64' -- ^ fallback value + } -> `Word64' fromIntegral #} + +channelGetUInt64 :: XfconfChannelClass self => self -> String -> IO Word64 +channelGetUInt64 chan prop = channelGetUInt64WithDefault chan prop 0 + +{#fun unsafe channel_set_uint64 as channelSetUInt64 + `XfconfChannelClass self' => + { withXfconf* `self' -- ^ channel pointer + , withUTFString* `String' -- ^ property + , fromIntegral `Word64' -- ^ new value + } -> `Bool' toBool #} + +--- Boolean +{#fun unsafe channel_get_bool as channelGetBoolWithDefault + `XfconfChannelClass self' => + { withXfconf* `self' -- ^ channel pointer + , withUTFString* `String' -- ^ property + , fromBool `Bool' -- ^ fallback value + } -> `Bool' toBool #} + +channelGetBool :: XfconfChannelClass self => self -> String -> IO Bool +channelGetBool chan prop = channelGetBoolWithDefault chan prop False + +{#fun unsafe channel_set_bool as ^ + `XfconfChannelClass self' => + { withXfconf* `self' -- ^ channel pointer + , withUTFString* `String' -- ^ property + , fromBool `Bool' -- ^ new value + } -> `Bool' toBool #} + +--- Double +{#fun unsafe channel_get_double as channelGetDoubleWithDefault + `XfconfChannelClass self' => + { withXfconf* `self' -- ^ channel pointer + , withUTFString* `String' -- ^ property + , realToFrac `Double' -- ^ fallback value + } -> `Double' realToFrac #} + +channelGetDouble :: XfconfChannelClass self => self -> String -> IO Double +channelGetDouble chan prop = channelGetDoubleWithDefault chan prop 0.0 + +{#fun unsafe channel_set_double as ^ + `XfconfChannelClass self' => + { withXfconf* `self' -- ^ channel pointer + , withUTFString* `String' -- ^ property + , realToFrac `Double' -- ^ new value + } -> `Bool' toBool #} + +--- String +{#fun unsafe channel_get_string as channelGetStringWithDefault + `XfconfChannelClass self' => + { withXfconf* `self' -- ^ channel pointer + , withUTFString* `String' -- ^ property + , withUTFString* `String' -- ^ fallback value + } -> `String' readUTFString* #} + +channelGetString :: XfconfChannelClass self => self -> String -> IO String +channelGetString channel prop = channelGetStringWithDefault channel prop "N/A" + +{#fun unsafe channel_set_string as ^ + `XfconfChannelClass self' => + { withXfconf* `self' -- ^ channel pointer + , withUTFString* `String' -- ^ property + , withUTFString* `String' -- ^ new value + } -> `Bool' toBool #} + +{---------------------------------------------------------------------- +-- gint16 and guint16 +----------------------------------------------------------------------} + +-- $special16bits +-- The same remark as for the previous \"basic values\" applies. + +-- common infrastructure, since xfconf doesn't have raw get/set for +-- uint16 and int16, we will use channel_get/set_property with GValues +foreign import ccall unsafe "xfconf.h xfconf_channel_get_property" + c_get_property :: Ptr XfconfChannel -- ^ channel pointer + -> Ptr CChar -- ^ property + -> Ptr GValue -- ^ gvalue* + -> IO CInt -- ^ success + +foreign import ccall unsafe "xfconf.h xfconf_channel_set_property" + c_set_property :: Ptr XfconfChannel -- ^ channel pointer + -> Ptr CChar -- ^ property + -> Ptr GValue -- ^ gvalue* + -> IO CInt -- ^ success + +--- UINT16 +channelGetUInt16WithDefault :: XfconfChannelClass self + => self -> String -> Word16 -> IO Word16 +channelGetUInt16WithDefault chan property i = + withXfconf chan $ \chanPtr -> + withUTFString property $ \prop -> + allocaGValue $ \(GValue gPtr) -> do + r <- c_get_property chanPtr prop gPtr + case toBool r of + False -> return i + -- FIXME: Integer store as uint16 are retrieved as UInt. + -- This is a bug present in the C version of the library. + -- Not the present FFI binding fault. + True -> do { v <- toXfconfValue (GValue gPtr) + ; case v of + ; XfconfUInt16 x -> return x + ; XfconfUInt x -> return (fromIntegral x) + ; _ -> error "Cannot decode gPtr UInt16" } + +channelGetUInt16 :: XfconfChannelClass self + => self -> String -> IO Word16 +channelGetUInt16 chan prop = channelGetUInt16WithDefault chan prop 0 + +channelSetUInt16 :: XfconfChannelClass self + => self -> String -> Word16 -> IO Bool +channelSetUInt16 chan property i = + withXfconf chan $ \chanPtr -> + withUTFString property $ \prop -> + allocaGValue $ \gvalue@(GValue gPtr) -> do + valueInit gvalue uint16 + valueSetUInt16 gvalue (fromIntegral i) + r <- c_set_property chanPtr prop gPtr + return (toBool r) + +--- INT16 +channelGetInt16WithDefault :: XfconfChannelClass self + => self -> String -> Int16 -> IO Int16 +channelGetInt16WithDefault chan property i = + withXfconf chan $ \chanPtr -> + withUTFString property $ \prop -> + allocaGValue $ \gvalue@(GValue gPtr) -> do + r <- c_get_property chanPtr prop gPtr + case toBool r of + False -> return i + -- FIXME: Same \"bug\" as before, xfconfd return Int16 as + -- simple Int. So we cheat a little in Haskell to keep + -- things coherent. + True -> do { v <- toXfconfValue gvalue + ; case v of + ; XfconfInt16 x -> return x + ; XfconfInt x -> return (fromIntegral x) + ; _ -> error "Cannot decode gPtr Int16" } + +channelGetInt16 :: XfconfChannelClass self + => self -> String -> IO Int16 +channelGetInt16 chan prop = channelGetInt16WithDefault chan prop 0 + +channelSetInt16 :: XfconfChannelClass self + => self -> String -> Int16 -> IO Bool +channelSetInt16 chan property i = + withXfconf chan $ \chanPtr -> + withUTFString property $ \prop -> + allocaGValue $ \gvalue@(GValue gPtr) -> do + valueInit gvalue int16 + valueSetInt16 gvalue (fromIntegral i) + r <- c_set_property chanPtr prop gPtr + return (toBool r) + +{---------------------------------------------------------------------- +-- Complex values set/get aka the f***ing stuff +----------------------------------------------------------------------} + +-- $complexValues +-- C Arrays, structures and named structures are not implemented. +-- (correction: you can now retrieve and store arrays, just do not play +-- with complex arrays -- eg. no array of arrays -- and be careful of +-- the difference betwwen 'channelSetStringList', 'channelGetArray' or +-- 'channelGetProperty'). + +--- String List +{#fun unsafe channel_get_string_list as ^ + `XfconfChannelClass self' => + { withXfconf* `self' -- ^ channel pointer + , withUTFString* `String' -- ^ property + } -> `[String]' readUTFStrings* #} + + where readUTFStrings ptr = if ptr == nullPtr + then return [] + else readUTFStringArray0 ptr + +{#fun unsafe channel_set_string_list as c_set_string_list + `XfconfChannelClass self' => + { withXfconf* `self' -- ^ channel pointer + , withUTFString* `String' -- ^ property + , withUTFStringArray0* `[String]' -- ^ new value + } -> `Bool' toBool #} + +-- | Handles [] empty string lists by resetting the value with +-- 'channelResetProperty' +channelSetStringList :: XfconfChannelClass self + => self -> String -> [String] -> IO Bool +channelSetStringList ch prop [] = channelResetProperty ch prop False >> return True +channelSetStringList ch prop xs = c_set_string_list ch prop xs + +channelGetArray :: XfconfChannelClass self + => self -> String -> IO [XfconfValue] +channelGetArray channel property = do + result <- channelGetProperty channel property + case result of + Just (XfconfArray xs) -> return xs + Nothing -> return [] + _ -> error "not a XfconfArray" + +channelSetArray :: (XfconfChannelClass self, XfconfValueClass a) + => self -> String -> [a] -> IO Bool +channelSetArray channel property xs = + withXfconf channel $ \conf -> + withUTFString property $ \prop -> + mapM toXfconfValue xs >>= \values -> + allocaGValueArray values $ \(GValue gptr) -> + c_set_property conf prop gptr >>= return . toBool + + +-- | Generic function for retrieving 'XfconfValue's. As for +-- 'channelGetProperties', only work with the limited set of simple +-- types supported by "System.XFCE.Xfconf.Values". +channelGetProperty :: XfconfChannelClass self + => self -> String -> IO (Maybe XfconfValue) +channelGetProperty chan property = + withXfconf chan $ \chanPtr -> + withUTFString property $ \prop -> + allocaGValue $ \gvalue@(GValue gPtr) -> do + success <- c_get_property chanPtr prop gPtr + case toBool success of + False -> do -- gvalue was not initialize by c_get_property + -- allocaGValue will try to unset it + -- and throw an error if our gvalue stay as it is + valueInit gvalue bool + return Nothing + True -> Just `fmap` toXfconfValue gvalue + +-- | Generic function for storing 'XfconfValue's. As for +-- 'channelGetProperties', only work with the limited set of simple +-- types supported by "System.XFCE.Xfconf.Values". +-- +-- Reset property and return True if @Maybe XfconfValue@ is 'Nothing' or +-- throw an error if the value is an instance of @Just +-- ('XfconfNotImplemented' t)@. +channelSetProperty :: (XfconfChannelClass self, XfconfValueClass a) + => self -> String -> Maybe a -> IO Bool + +channelSetProperty ch p Nothing = do + channelResetProperty ch p False + return True + +channelSetProperty ch p (Just v) = do + value <- toXfconfValue v + case value of + XfconfInt i -> channelSetInt ch p i + XfconfUInt i -> channelSetUInt ch p i + XfconfUInt64 i -> channelSetUInt64 ch p i + XfconfDouble d -> channelSetDouble ch p d + XfconfBool b -> channelSetBool ch p b + XfconfString s -> channelSetString ch p s + XfconfInt16 i -> channelSetInt16 ch p i + XfconfUInt16 i -> channelSetUInt16 ch p i + XfconfStringList l -> channelSetStringList ch p l + XfconfArray a -> channelSetArray ch p a + _ -> error "unknown XfconfValue type" + +-- | Retrieves multiple properties from 'Channel' and stores them in a +-- 'GHashTable' in which the keys correspond to the string property +-- names, and the values correspond to variant 'GValue' values. The +-- value of the property specified by the 'String' property_base and all +-- sub-properties are retrieved. To retrieve all properties in the +-- channel, specify \"/\". +{#fun unsafe channel_get_properties as c_get_properties + `XfconfChannelClass self' => + { withXfconf* `self' -- ^ channel + , withUTFString* `String' -- ^ property base + } -> `Maybe GHashTable' marshallGHashTable* #} + + where marshallGHashTable ptr = if ptr == nullPtr + then return Nothing + else Just `fmap` mkGHashTable ptr + +-- | A convenience function returning an association list [(key, +-- value)]. Work only for the data types defined in +-- "System.XFCE.Xfconf.Values" (i.e. no (named) structures). +-- See also the limitation imposed by 'gHashTableLookup'. The value of +-- the property specified by the 'String' property_base and all +-- sub-properties are retrieved. To retrieve all properties in the +-- channel, specify \"/\". +channelGetProperties :: XfconfChannelClass self + => self -> String -> IO [(String, Maybe XfconfValue)] +channelGetProperties chan prop = do + maybeGHT <- c_get_properties chan prop + case maybeGHT of + Nothing -> return [] + Just ght -> do keys <- gHashTableKeys ght + values <- mapM (gLookup ght) keys + return (zip keys values) + + where gLookup :: GHashTable -> String -> IO (Maybe XfconfValue) + gLookup ght key = do value <- gHashTableLookup ght key + case value of + Nothing -> return Nothing + Just x -> Just `fmap` toXfconfValue x + +-- | Alias to @channelGetProperties channel \"/\"@ +channelGetAllProperties :: XfconfChannelClass self => self + -> IO [(String, Maybe XfconfValue)] +channelGetAllProperties c = channelGetProperties c "/" + +-- | A convenience function equivalent to +-- @ +-- mapM (\(k,v) -> channelSetProperty channel k v) properties +-- @ +channelSetProperties :: (XfconfChannelClass self, XfconfValueClass a) + => self -> [(String, Maybe a)] -> IO [Bool] +channelSetProperties chan = mapM (\(k,v) -> channelSetProperty chan k v) + +{---------------------------------------------------------------------- +-- TODO + +- xfconf-channel.h function list +- +- > bash $ sed '/^\(\/\| \*\|#\)/d' xfconf-channel.h | grep '(' +- +DONE xfconf_channel_get_type +TESTED xfconf_channel_get +TESTED xfconf_channel_new +TESTED xfconf_channel_new_with_property_base +TESTED xfconf_channel_has_property +TESTED xfconf_channel_is_property_locked +TESTED xfconf_channel_reset_property +TESTED xfconf_channel_get_properties +TESTED xfconf_channel_get_string +TESTED xfconf_channel_set_string +TESTED xfconf_channel_get_int +TESTED xfconf_channel_set_int +TESTED xfconf_channel_get_uint +TESTED xfconf_channel_set_uint +TESTED xfconf_channel_get_uint64 +TESTED xfconf_channel_set_uint64 +TESTED xfconf_channel_get_double +TESTED xfconf_channel_set_double +TESTED xfconf_channel_get_bool +TESTED xfconf_channel_set_bool +TESTED xfconf_channel_get_string_list +TESTED xfconf_channel_set_string_list +PARTIAL xfconf_channel_get_property +PARTIAL xfconf_channel_set_property +SOMEHOW xfconf_channel_get_array + xfconf_channel_get_array_valist + xfconf_channel_get_arrayv +SOMEHOW xfconf_channel_set_array + xfconf_channel_set_array_valist + xfconf_channel_set_arrayv + xfconf_channel_get_named_struct + xfconf_channel_set_named_struct + xfconf_channel_get_struct + xfconf_channel_get_struct_valist + xfconf_channel_get_structv + xfconf_channel_set_struct + xfconf_channel_set_struct_valist + xfconf_channel_set_structv + +- xfconf-channel.h attributes list +TESTED channel-name +TESTED property-base + +- xfconf-channel.h signals list +TESTED property-changed + +----------------------------------------------------------------------} + +-- vim:filetype=haskell: diff --git a/System/XFCE/Xfconf/Core.chs b/System/XFCE/Xfconf/Core.chs new file mode 100644 --- /dev/null +++ b/System/XFCE/Xfconf/Core.chs @@ -0,0 +1,44 @@ +{-# LANGUAGE CPP, ForeignFunctionInterface #-} +-- vim:filetype=haskell: +-- + +-- XXX: Should we consider property names to be encoded in UTF-8 too +-- (string values are already encoded to / decoded from UTF-8). + +{- | Core functionalities for libxfconf. + + There is actually only one core function : 'xfconfListChannels'. + Access to the C functions xfconf_init() and xfconf_shutdown() are + available in the "System.XFCE.Xfconf.Unsafe" module and should, in + most cases, not be used in Haskell. + + For more information, see: + http:\/\/docs.xfce.org\/api\/xfconf\/xfconf-xfconf.html +-} + + +#include + +{# context lib="xfconf-0" prefix="xfconf" #} + +module System.XFCE.Xfconf.Core ( + xfconfListChannels, + ) where + +import Control.Exception (bracket_) + +import System.Glib.UTFString + +import System.XFCE.Xfconf.FFI +{#import System.XFCE.Xfconf.Unsafe #} + +{---------------------------------------------------------------------- +-- Core +----------------------------------------------------------------------} + +-- | List the names of available channels. +xfconfListChannels :: IO [String] +xfconfListChannels = bracket_ xfconfInit xfconfShutdown $ + {#call unsafe xfconf_list_channels #} >>= readUTFStringArray0 + +-- TODO: implement xfconf_named_struct_register diff --git a/System/XFCE/Xfconf/Error.chs b/System/XFCE/Xfconf/Error.chs new file mode 100644 --- /dev/null +++ b/System/XFCE/Xfconf/Error.chs @@ -0,0 +1,70 @@ +{-# LANGUAGE CPP, ForeignFunctionInterface #-} + +-- | Xfconf library and daemon error descriptions +-- +-- Both the Xfconf daemon and library provide error information via the +-- use of GErrors. +-- +-- For more information, see: +-- http:\/\/docs.xfce.org\/api\/xfconf\/xfconf-xfconf-errors.html + + +#include + +{# context lib="xfconf-0" #} + +module System.XFCE.Xfconf.Error ( + XfconfError(..), + xfconfErrorDomain + ) where + +import System.Glib.GError + +import System.XFCE.Xfconf.FFI + +{---------------------------------------------------------------------- +-- Xfconf Error +----------------------------------------------------------------------} + +-- | The 'GErrorDomain' for Xfconf. +xfconfErrorDomain :: GErrorDomain +xfconfErrorDomain = {#call pure unsafe xfconf_get_error_quark#} + +{- | An enumeration listing the different kinds of errors under the + 'xfconfErrorDomain' domain. + + [@xfconfErrorUnknown@] + An unknown error occurred + + [@xfconfErrorChannelNotFound@] + The specified channel does not exist + + [@xfconfErrorPropertyNotFound@] + The specified property does not exist on the channel + + [@xfconfErrorReadFailure@] + There was a failure reading from the configuration store + + [@xfconfErrorWriteFailure@] + There was a failure writing to the configuration store + + [@xfconfErrorPermissionDenied@] + The user is not allowed to read or write to the channel or + property + + [@xfconfErrorInternalError@] + An internal error (likely a bug in xfconf) occurred + + [@xfconfErrorNoBackend@] + No backends were found, or those found could not be loaded + + [@xfconfErrorInvalidProperty@] + The property name specified was invalid + + [@xfconfErrorInvalidChannel@] + The channel name specified was invalid +-} +{#enum XfconfError {underscoreToCase} #} + +instance GErrorClass XfconfError where + gerrorDomain _ = xfconfErrorDomain diff --git a/System/XFCE/Xfconf/FFI.hs b/System/XFCE/Xfconf/FFI.hs new file mode 100644 --- /dev/null +++ b/System/XFCE/Xfconf/FFI.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +-- +-- + +module System.XFCE.Xfconf.FFI ( + -- * Glib + g_free, + + -- * Re-exported Common FFI stuff + module Foreign, + module Foreign.C.Types, + module Foreign.C.String + ) where + +import Foreign +import Foreign.C.Types +import Foreign.C.String + +foreign import ccall unsafe "glib.h g_free" + g_free :: Ptr a -> IO () diff --git a/System/XFCE/Xfconf/GHashTable.chs b/System/XFCE/Xfconf/GHashTable.chs new file mode 100644 --- /dev/null +++ b/System/XFCE/Xfconf/GHashTable.chs @@ -0,0 +1,96 @@ +{-# LANGUAGE CPP, ForeignFunctionInterface #-} +-- vim:filetype=haskell: + +{- | A limited binding to glib GHashTable structures. We only handle + hash tables as returned by @xfconf_channel_get_properties@. They have + @gchar *@ keys and @GValue *@ values. + + Objectives: + + * get back the list of keys when keys are strings + + * extract values +-} + +#include + +{# context lib="glib" prefix="g_hash_table" #} + +module System.XFCE.Xfconf.GHashTable ( + -- * Private data type + GHashTable, + -- * Marshalling functions + withGHashTable, + mkGHashTable, + -- * Query functions + gHashTableKeys, + gHashTableLookup + ) where + +import Control.Monad ((>=>)) + +import System.Glib.GList +import System.Glib.GValue +import System.Glib.UTFString + +import System.XFCE.Xfconf.FFI + +-- | Haskell representation of a C @GHashTable*@ with @gchar *@ keys and +-- @GValue*@ values. Memory management is automatically managed by a +-- special Haskell finalizer calling @g_hash_table_destroy@. +{#pointer *GHashTable as GHashTable foreign newtype #} +-- withGHashTable is auto-generated by C2HS, but not by gtk2hsC2hs +withGHashTable :: GHashTable -> (Ptr GHashTable -> IO b) -> IO b +withGHashTable (GHashTable ptr) = withForeignPtr ptr + +-- | The glib finalizer for hash tables. +foreign import ccall unsafe "glib.h &g_hash_table_destroy" + c_destroy :: FinalizerPtr GHashTable + +{- | Marshal out a raw C @GHashTable*@ by wrapping it in the Haskell + type 'GHashTable' and adding it a finalizer (which calls + @g_hash_table_destroy@). + + Should be called for every function returning a @GHashTable*@, see + for example in /System.XFCE.Xfconf.Channel.chs/: + + @ + {#fun unsafe get_properties as ^ + { channelPtr \`Channel\' -- ^ channel pointer + , withUTFString* \`String\' -- ^ property base + } -> \`GHashTable\' mkGHashTable* #} + @ +-} +mkGHashTable :: Ptr GHashTable -> IO (GHashTable) +mkGHashTable ptr = GHashTable `fmap` newForeignPtr c_destroy ptr + +-- XXX: fromGList calls g_list_delete_link which I suppose is the same +-- as calling g_list_free +-- XXX: readGList read whereas fromGList read *and* free the list +-- peekUTFString read whereas readUTFString read *and* free the str +-- somewhat, I feel completely lost (^^) +-- XXX: we do NOT readUTFString, we just peek them ! +-- the GHashTablePtr finalizer should take care itself of freeing +-- them +-- | Retrieves every key inside a 'GHashTable'. The returned data is +-- valid until the table is modified. +{#fun unsafe get_keys as gHashTableKeys + { withGHashTable* `GHashTable' + } -> `[String]' marshallOut* #} + where marshallOut = fromGList >=> mapM peekUTFString + +-- | Looks up a key in a GHashTable. Note that this function cannot +-- distinguish between a key that is not present and one which is +-- present and has the value 'Nothing'. +{#fun unsafe lookup as gHashTableLookup + { withGHashTable* `GHashTable' + , withUTFString'* `String' + } -> `Maybe GValue' marshallGValue #} + + where withUTFString' :: String -> (Ptr () -> IO b) -> IO b + withUTFString' s io = withUTFString s (io . castPtr) + + marshallGValue :: Ptr a -> Maybe GValue + marshallGValue ptr = if ptr == nullPtr + then Nothing + else Just . GValue . castPtr $ ptr diff --git a/System/XFCE/Xfconf/Signals.chs b/System/XFCE/Xfconf/Signals.chs new file mode 100644 --- /dev/null +++ b/System/XFCE/Xfconf/Signals.chs @@ -0,0 +1,76 @@ +{-# OPTIONS_HADDOCK hide #-} +-- -*-haskell-*- +-- -------------------- automatically generated file - do not edit ------------ +-- Callback installers for the GIMP Toolkit (GTK) Binding for Haskell +-- +-- Author : Axel Simon +-- +-- Created: 1 July 2000 +-- +-- Copyright (C) 2000-2005 Axel Simon +-- +-- This library is free software; you can redistribute it and/or +-- modify it under the terms of the GNU Lesser General Public +-- License as published by the Free Software Foundation; either +-- version 2.1 of the License, or (at your option) any later version. +-- +-- This library is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +-- Lesser General Public License for more details. +-- +-- #hide + +-- These functions are used to connect signals to widgets. They are auto- +-- matically created through HookGenerator.hs which takes a list of possible +-- function signatures that are included in the GTK sources (gtkmarshal.list). +-- +-- The object system in the second version of GTK is based on GObject from +-- GLIB. This base class is rather primitive in that it only implements +-- ref and unref methods (and others that are not interesting to us). If +-- the marshall list mentions OBJECT it refers to an instance of this +-- GObject which is automatically wrapped with a ref and unref call. +-- Structures which are not derived from GObject have to be passed as +-- BOXED which gives the signal connect function a possibility to do the +-- conversion into a proper ForeignPtr type. In special cases the signal +-- connect function use a PTR type which will then be mangled in the +-- user function directly. The latter is needed if a signal delivers a +-- pointer to a string and its length in a separate integer. +-- +module System.XFCE.Xfconf.Signals ( + module System.Glib.Signals, + + connect_STRING_PTR__NONE, + + ) where + +import Control.Monad (liftM) + +import System.Glib.FFI +import System.Glib.UTFString (peekUTFString,maybePeekUTFString) +import System.Glib.GError (failOnGError) +{#import System.Glib.Signals#} +{#import System.Glib.GObject#} + + +{#context lib="gtk" prefix="gtk" #} + + +-- Here are the generators that turn a Haskell function into +-- a C function pointer. The fist Argument is always the widget, +-- the last one is the user g_pointer. Both are ignored. + + +connect_STRING_PTR__NONE :: + GObjectClass obj => SignalName -> + ConnectAfter -> obj -> + (String -> Ptr b -> IO ()) -> + IO (ConnectId obj) +connect_STRING_PTR__NONE signal after obj user = + connectGeneric signal after obj action + where action :: Ptr GObject -> CString -> Ptr () -> IO () + action _ str1 ptr2 = + failOnGError $ + peekUTFString str1 >>= \str1' -> + user str1' (castPtr ptr2) + diff --git a/System/XFCE/Xfconf/Types.chs b/System/XFCE/Xfconf/Types.chs new file mode 100644 --- /dev/null +++ b/System/XFCE/Xfconf/Types.chs @@ -0,0 +1,85 @@ +{-# OPTIONS_HADDOCK hide #-} +-- -*-haskell-*- +-- -------------------- automatically generated file - do not edit ---------- +-- Object hierarchy for the GIMP Toolkit (GTK) Binding for Haskell +-- +-- Author : Axel Simon +-- +-- Copyright (C) 2001-2005 Axel Simon +-- +-- This library is free software; you can redistribute it and/or +-- modify it under the terms of the GNU Lesser General Public +-- License as published by the Free Software Foundation; either +-- version 2.1 of the License, or (at your option) any later version. +-- +-- This library is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +-- Lesser General Public License for more details. +-- +-- #hide + +-- | +-- Maintainer : gtk2hs-users@lists.sourceforge.net +-- Stability : provisional +-- Portability : portable (depends on GHC) +-- +-- This file reflects the Gtk+ object hierarchy in terms of Haskell classes. +-- +-- Note: the mk... functions were originally meant to simply be an alias +-- for the constructor. However, in order to communicate the destructor +-- of an object to objectNew, the mk... functions are now a tuple containing +-- Haskell constructor and the destructor function pointer. This hack avoids +-- changing all modules that simply pass mk... to objectNew. +-- +module System.XFCE.Xfconf.Types ( + + XfconfChannel(XfconfChannel), XfconfChannelClass, + toXfconfChannel, + mkXfconfChannel, unXfconfChannel, + castToXfconfChannel, gTypeXfconfChannel + ) where + +import Foreign.ForeignPtr (ForeignPtr, castForeignPtr, unsafeForeignPtrToPtr) +import Foreign.C.Types (CULong, CUInt) +import System.Glib.GType (GType, typeInstanceIsA) +import System.Glib.GObject + +{# context lib="gtk" prefix="gtk" #} + +-- The usage of foreignPtrToPtr should be safe as the evaluation will only be +-- forced if the object is used afterwards +-- +castTo :: (GObjectClass obj, GObjectClass obj') => GType -> String + -> (obj -> obj') +castTo gtype objTypeName obj = + case toGObject obj of + gobj@(GObject objFPtr) + | typeInstanceIsA ((unsafeForeignPtrToPtr.castForeignPtr) objFPtr) gtype + -> unsafeCastGObject gobj + | otherwise -> error $ "Cannot cast object to " ++ objTypeName + + +-- ************************************************************** XfconfChannel + +{#pointer *XfconfChannel foreign newtype #} deriving (Eq,Ord) + +mkXfconfChannel = (XfconfChannel, objectUnref) +unXfconfChannel (XfconfChannel o) = o + +class GObjectClass o => XfconfChannelClass o +toXfconfChannel :: XfconfChannelClass o => o -> XfconfChannel +toXfconfChannel = unsafeCastGObject . toGObject + +instance XfconfChannelClass XfconfChannel +instance GObjectClass XfconfChannel where + toGObject = GObject . castForeignPtr . unXfconfChannel + unsafeCastGObject = XfconfChannel . castForeignPtr . unGObject + +castToXfconfChannel :: GObjectClass obj => obj -> XfconfChannel +castToXfconfChannel = castTo gTypeXfconfChannel "XfconfChannel" + +gTypeXfconfChannel :: GType +gTypeXfconfChannel = + {# call fun unsafe xfconf_channel_get_type #} + diff --git a/System/XFCE/Xfconf/Unsafe.chs b/System/XFCE/Xfconf/Unsafe.chs new file mode 100644 --- /dev/null +++ b/System/XFCE/Xfconf/Unsafe.chs @@ -0,0 +1,64 @@ +{-# LANGUAGE CPP, ForeignFunctionInterface #-} +-- vim:filetype=haskell: +-- + +-- XXX: Should we consider property names to be encoded in UTF-8 too +-- (string values are already encoded to / decoded from UTF-8). + +{- | Legacy core functions from the C implementation. + + Before libxfconf can be use, it must be initialized by calling + 'xfconfInit'. To free resources used by the library, call + 'xfconfShutdown'. These calls are "recursive": multiple calls to + 'xfconfInit' are allowed, but each call must be matched by a + separate call to 'xfconfShutdown' to really free the library's + resources. + + For more information, see: + http:\/\/docs.xfce.org\/api\/xfconf\/xfconf-xfconf.html +-} + + +#include + +{# context lib="xfconf-0" prefix="xfconf" #} + +module System.XFCE.Xfconf.Unsafe ( + xfconfInit, + xfconfShutdown, + ) where + +import System.Glib.GError (propagateGError) + +import System.XFCE.Xfconf.FFI + +{---------------------------------------------------------------------- +-- Core +----------------------------------------------------------------------} + +foreign import ccall unsafe "xfconf_init" + c_xfconf_init :: Ptr (Ptr ()) -> IO () + +-- | Initializes the Xfconf library. Can be called multiple times with +-- no adverse effects. +-- +-- May throw a 'GError'. You can try to catch it with: +-- +-- @ +-- catchGError xfconfInit +-- (\(GError d c m) -> do print d;print c;print m) +-- @ +-- +-- N.B.: most Haskell functions automatically calls xfconfInit when +-- needed. You should NOT directly use this function. +xfconfInit :: IO () +xfconfInit = propagateGError (\errPtrPtr -> c_xfconf_init errPtrPtr) + +-- | Shuts down and frees any resources consumed by the Xfconf library. +-- If 'xfconfInit' is called multiple times, 'xfconfShutdown' must be +-- called an equal number of times to shut down the library. +-- +-- N.B.: most Haskell functions automatically calls xfconfShutdown when +-- needed. You should NOT directly use this function. +xfconfShutdown :: IO () +xfconfShutdown = {#call unsafe xfconf_shutdown #} diff --git a/System/XFCE/Xfconf/Values.chs b/System/XFCE/Xfconf/Values.chs new file mode 100644 --- /dev/null +++ b/System/XFCE/Xfconf/Values.chs @@ -0,0 +1,302 @@ +{-# 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 instructions +-- I let them here, because they are pretty. +#include +#include +#include + +{# 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 diff --git a/Tests/TestGlib.hs b/Tests/TestGlib.hs new file mode 100644 --- /dev/null +++ b/Tests/TestGlib.hs @@ -0,0 +1,105 @@ +module Main where + +import Test.QuickCheck +import Test.QuickCheck.Monadic as QCM +import Test.Framework (defaultMain, testGroup) +import Test.Framework.Providers.QuickCheck2 + +import Control.Concurrent.MVar +import Control.Concurrent (forkIO, threadDelay) +import Control.Exception (bracket_) + +import System.XFCE.Xfconf +import System.Glib.MainLoop +import System.Glib.Signals (signalDisconnect) + +sleep :: Int -> IO () +sleep = threadDelay . (1000000*) + +msleep :: Int -> IO () +msleep = threadDelay . (1000*) + +-- | garbage string, just be careful to avoid C-String delimiter ('\0') +genUTFString :: Gen String +genUTFString = suchThat arbitrary (notElem '\0') + +-- | same as above but without empty strings +genUTFString1 :: Gen String +genUTFString1 = suchThat genUTFString (not . null) + +testSignal :: Property +testSignal = monadicIO $ do + value <- pick genUTFString1 + value' <- QCM.run $ setAndRetrieveWithGlib value + QCM.assert (value == value') + +debugInOut n = bracket_ (putStrLn i) (putStrLn o) + where i = "inside " ++ n + o = "outside " ++ n + +setAndRetrieveWithGlib :: String -> IO String +setAndRetrieveWithGlib value = do + if null value + then error "rondedjiu, beware the deadlocks \ + \with your empty strings!" + else return () + + let chanName = "QuickCheck" + propName = "/SignalCheck" + + chan <- channelGet chanName + result <- newEmptyMVar + + -- Init property to a dummy value, since xfconfd will only + -- trigger the callback if our future new value is different + -- from the present one + debugInOut "setDummyString" $ channelSetString chan propName "init" + + -- we sleep, otherwise our previous "set" action might get + -- caught by the following signal handler + debugInOut "sleep(1)" $ msleep 40 + + -- We set our signal handler. Note that the glib loop has been + -- forked away from this process so the following operation will + -- be processed apart. + sigid <- onPropertyChanged chan $ \_ maybeValue -> debugInOut "onPropertyChanged" $ do + cond <- isEmptyMVar result + if cond + then case maybeValue of + Just (XfconfString s) -> putMVar result s + Nothing -> putMVar result "" + _ -> putMVar result "UNKNWOW value" + else do putStrLn "DANGER, WILL ROBINSON !" + error "you are going to fast !" + + + debugInOut "sleep(2)" $ msleep 40 + + -- We resume our main thread here, by trigerring the previous + -- signal (that what we were testing, remember ?) + debugInOut "setNewString" $ channelSetString chan propName value + + -- ... and wait for the answer from the glib loop + maybeValue' <- tryTakeMVar result + + -- pseudo process cleaning + signalDisconnect sigid + + maybe (return "N/A") return maybeValue' + --return value' -- return value' to QuickCheck.Monadic + +main = do + loop <- mainLoopNew Nothing True + debugInOut "fork" $ forkIO $ mainLoopRun loop + msleep 100 >> setAndRetrieveWithGlib "foo" >>= putStr + msleep 500 >> mainLoopQuit loop + +main :: IO () +main' = do + loop <- mainLoopNew Nothing True + forkIO $ mainLoopRun loop + defaultMain testSuite >> mainLoopQuit loop + + where testSuite = [ testGroup "GLib loop" + [testProperty "onPropertyChanged" testSignal] + ] diff --git a/Tests/Tests.hs b/Tests/Tests.hs new file mode 100644 --- /dev/null +++ b/Tests/Tests.hs @@ -0,0 +1,270 @@ +{-| some tests you can run with `runghc -lxfconf-0 Tests/Tests` -} +-- A rewrite of the previous tests using monadic quickcheck + +module Main where + +import Test.Framework (defaultMain, testGroup) +import Test.Framework.Providers.HUnit +import Test.Framework.Providers.QuickCheck2 +import Test.HUnit + +import Test.QuickCheck +import Test.QuickCheck.Monadic as QCM + +import Control.Concurrent (threadDelay) +import Data.Char (toLower) +import Text.Printf + +import System.XFCE.Xfconf + +myChannel = "QuickCheck" + +main :: IO () +main = defaultMain testSuite + + -- we need to sleep because garbace collection must collect objects + -- before we shutdown xfconf (!! this sucks !!) + where msleep = threadDelay . (1000*) + +testSuitv = [ testGroup "Debugging" + [ testStringList + ] + ] + +testSuite = [ testGroup "QuickCheck" + [ testChannelPropertyBase + , testXfconfValue + , testXfconfArray + , testStringList + , testStringArray + , testString + , testDouble + , testInt + , testUInt + , testInt16 + , testUInt16 + , testUInt64 + , testBool + ] + , testGroup "HUnit" + [ testChannels + , testHasProperty + , testPropertyLocked + , testGetKeys + , testGetProperties + , testResetProperties + , testChannelName + ] + ] + +-- | Really dumb test +testChannels = testCase "xfconf_list_channels" $ do + putStrLn " Available channels:" + + xfconfListChannels >>= printStringArray + + assertBool "Query list of channels" True + +testHasProperty = testCase "xfconf_channel_has_property" $ do + chan <- channelGet "xfce4-desktop" + dummy <- channelHasProperty chan "/no/property" + img <- channelHasProperty chan "/backdrop/screen0/monitor0/image-path" + + assertBool "Non-existing property" (dummy == False) + assertBool "Existing property" (img == True) + +testPropertyLocked = testCase "xfconf_channel_is_property_locked" $ do + chan <- channelGet "xsettings" + value <- channelIsPropertyLocked chan "/Net/ThemeName" + + assertBool "Property should not be locked" (value == False) + +testResetProperties = testCase "xfconf_channel_reset_property" $ do + chan <- channelGet "QuickCheck" + channelResetProperty chan "/" True + alist <- chan `channelGetProperties` "/" + + assertBool "Channel not empty" (null alist) + +testChannelName = testCase "channel attribute name" $ do + let name = myChannel + name' <- channelGetName =<< channelGet name + name'' <- channelGetName =<< channelNew name + name''' <- channelGetName =<< channelNewWithPropertyBase name "/foo" + + assertBool "channelGet name" (name === name') + assertBool "channelNew name" (name === name'') + assertBool "channelNewWithPropertyBase name" (name === name''') + + where s === s' = lower s == lower s' + lower = map toLower + + +{---------------------------------------------------------------------- +-- Serious business goes here +-- (well, it was serious because I had to implement GHashTable bindings) +----------------------------------------------------------------------} + +testGetKeys = + testCase "listing keys from a GHashTable" $ do + putStrLn " xfce4-desktop keys list:" + + desktop <- channelGet "xfce4-desktop" + channelGetKeys desktop "/" >>= printStringArray + + assertBool "Query list of channel keys" True + +testGetProperties = + testCase "listing properties from a GHashTable" $ do + putStrLn " QuickCheck properties list:" + + desktop <- channelGet "QuickCheck" + channelGetProperties desktop "/" >>= printTuples + + assertBool "Query list of channel properties" True + + +{---------------------------------------------------------------------- +-- QuickCheck.v2 +----------------------------------------------------------------------} + +testChannelPropertyBase = + testProperty "channel attribute property base" $ monadicIO $ do + base <- pick genAsciiString + chan <- QCM.run $ channelNewWithPropertyBase myChannel base + base' <- QCM.run $ channelGetPropertyBase chan + + QCM.assert (base' == base) + +-- | garbage string, just be careful to avoid C-String delimiter ('\0') +genUTFString :: Gen String +genUTFString = suchThat arbitrary (notElem '\0') + +genAsciiString :: Gen String +genAsciiString = listOf1 (elements ascii) + where ascii = ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ " \t" + +-- Warnings: +-- +-- XfconfStringList [String] are returned as +-- XfconfArray [XfconfString s] +-- +-- (U)Int16 are returned as plain (U)Int by xfconfd +genBasicXfconfValue :: Gen XfconfValue +genBasicXfconfValue = oneof [ XfconfString `fmap` genUTFString + , XfconfInt `fmap` arbitrary + , XfconfUInt `fmap` arbitrarySizedIntegral + , XfconfUInt64 `fmap` arbitrarySizedIntegral + , XfconfDouble `fmap` arbitrary + , XfconfBool `fmap` arbitrary + ] + +testXfconfValue = testValue "XfconfValue" + -- setProperty Nothing is cursed by the + -- monomorphism restriction + (Just `fmap` genBasicXfconfValue) + channelGetProperty + channelSetProperty +testXfconfArray = testValue "XfconfArray" + (listOf genBasicXfconfValue) + channelGetArray + channelSetArray +testStringArray = testValue "StringArray" + (listOf genUTFString) + channelGetStringArray + channelSetStringList + -- We will re-use our 'testValue' function but since it expect the Get + -- and Set operator to work with the same type, we provide an hackish + -- function to convert an XfconfArray [XfconfString] to [String] + where channelGetStringArray :: XfconfChannel -> String -> IO [String] + channelGetStringArray ch prop = do + r <- channelGetProperty ch prop + case r of + Just (XfconfArray v) -> return (map fromXfconfString v) + Nothing -> return [] + _ -> error "internal error" + + fromXfconfString (XfconfString s) = s + fromXfconfString _ = error "expect XfconfString" + +testStringList = testValue "StringList" + (listOf genUTFString) + channelGetStringList + channelSetStringList +testString = testValue "String" + genUTFString + channelGetString + channelSetString +testDouble = testValue "Double" + arbitrary + channelGetDouble + channelSetDouble +testInt = testValue "Int" + arbitrary + channelGetInt + channelSetInt +testUInt = testValue "UInt" + arbitrarySizedIntegral + channelGetUInt + channelSetUInt +testInt16 = testValue "Int16" + arbitrarySizedIntegral + channelGetInt16 + channelSetInt16 +testUInt16 = testValue "UInt16" + arbitrarySizedIntegral + channelGetUInt16 + channelSetUInt16 +testUInt64 = testValue "UInt64" + arbitrarySizedIntegral + channelGetUInt64 + channelSetUInt64 +testBool = testValue "Bool" + arbitrary + channelGetBool + channelSetBool + +-- | Check generic read and write operations +testValue typeName gen getOp setOp = + testProperty testName $ QCM.monadicIO $ do + + value <- QCM.pick gen + value' <- QCM.run $ computeNewValue value + QCM.assert (value == value') + + where testName = "xfconf_channel_get/set " ++ typeName + computeNewValue v= do + -- we use the name of the type as xfconf property name + let prop = "/" ++ typeName + channel <- channelGet myChannel + + -- apply dummy test value + setOp channel prop v + -- Query xfconfd back + getOp channel prop + + +manualTestProperty setOp getOp value = do + channel <- channelGet myChannel + setOp channel prop value + value' <- getOp channel prop + let same = (value == value') + if same + then printf "Ok\n" + else printf "(value,value') = (%s, %s)\n" (show value) (show value') + + where prop = "/Manual" + +{---------------------------------------------------------------------- +-- Utilities +----------------------------------------------------------------------} + +-- | Pretty print function because I am getting bored watching tests +-- output +printStringArray :: [String] -> IO () +printStringArray xs = mapM_ (\x -> putStrLn (" " ++ show x)) xs + +printTuples :: [(String, Maybe XfconfValue)] -> IO () +printTuples xs = mapM_ fmt xs + where fmt (k,v) = putStrLn $ " " ++ k ++ ": " ++ show v + diff --git a/hierarchy.list b/hierarchy.list new file mode 100644 --- /dev/null +++ b/hierarchy.list @@ -0,0 +1,20 @@ +# This list is the result of a copy-and-paste from the GtkObject hierarchy +# html documentation. Deprecated widgets are uncommented. Some additional +# object have been defined at the end of the copied list. + +# The Gtk prefix of every object is removed, the other prefixes are +# kept. The indentation implies the object hierarchy. In case the +# type query function cannot be derived from the name or the type name +# is different, an alternative name and type query function can be +# specified by appending 'as typename, '. In case this +# function is not specified, the is converted to +# gtk__get_type where is where each upperscore +# letter is converted to an underscore and lowerletter. The underscore +# is omitted if an upperscore letter preceeded: GtkHButtonBox -> +# gtk_hbutton_box_get_type. The generation of a type can be +# conditional by appending 'if '. Such types are only produces if +# --tag= is given on the command line of TypeGenerator. + + + GObject + XfconfChannel as XfconfChannel if xfconf diff --git a/include/all.h b/include/all.h new file mode 100644 --- /dev/null +++ b/include/all.h @@ -0,0 +1,2 @@ +#include +#include diff --git a/include/xfconf-binding.h b/include/xfconf-binding.h new file mode 100644 --- /dev/null +++ b/include/xfconf-binding.h @@ -0,0 +1,54 @@ +/* + * xfconf + * + * Copyright (c) 2008 Brian Tarricone + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; version 2 of the License ONLY. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + */ + +#ifndef __XFCONF_BINDING_H__ +#define __XFCONF_BINDING_H__ + +#if !defined(LIBXFCONF_COMPILATION) && !defined(XFCONF_IN_XFCONF_H) +#error "Do not include xfconf-binding.h, as this file may change or disappear in the future. Include instead." +#endif + +#include +#include + +G_BEGIN_DECLS + +gulong xfconf_g_property_bind(XfconfChannel *channel, + const gchar *xfconf_property, + GType xfconf_property_type, + gpointer object, + const gchar *object_property); + +gulong xfconf_g_property_bind_gdkcolor(XfconfChannel *channel, + const gchar *xfconf_property, + gpointer object, + const gchar *object_property); + +void xfconf_g_property_unbind(gulong id); + +void xfconf_g_property_unbind_by_property(XfconfChannel *channel, + const gchar *xfconf_property, + gpointer object, + const gchar *object_property); + +void xfconf_g_property_unbind_all(gpointer channel_or_object); + +G_END_DECLS + +#endif /* __XFCONF_BINDING_H__ */ diff --git a/include/xfconf-channel.h b/include/xfconf-channel.h new file mode 100644 --- /dev/null +++ b/include/xfconf-channel.h @@ -0,0 +1,204 @@ +/* + * xfconf + * + * Copyright (c) 2007-2008 Brian Tarricone + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; version 2 of the License ONLY. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + */ + +#ifndef __XFCONF_CHANNEL_H__ +#define __XFCONF_CHANNEL_H__ + +#if !defined(LIBXFCONF_COMPILATION) && !defined(XFCONF_IN_XFCONF_H) +#error "Do not include xfconf-channel.h, as this file may change or disappear in the future. Include instead." +#endif + +#include + +#define XFCONF_TYPE_CHANNEL (xfconf_channel_get_type()) +#define XFCONF_CHANNEL(obj) (G_TYPE_CHECK_INSTANCE_CAST((obj), XFCONF_TYPE_CHANNEL, XfconfChannel)) +#define XFCONF_IS_CHANNEL(obj) (G_TYPE_CHECK_INSTANCE_TYPE((obj), XFCONF_TYPE_CHANNEL)) +#define XFCONF_CHANNEL_CLASS(klass) (G_TYPE_CHECK_CLASS_CAST((klass), XFCONF_TYPE_CHANNEL, XfconfChannelClass)) +#define XFCONF_IS_CHANNEL_CLASS(klass) (G_TYPE_CHECK_CLASS_TYPE((klass), XFCONF_TYPE_CHANNEL)) +#define XFCONF_CHANNEL_GET_CLASS(obj) (G_TYPE_INSTANCE_GET_CLASS((obj), XFCONF_TYPE_CHANNEL, XfconfChannelClass)) + +G_BEGIN_DECLS + +typedef struct _XfconfChannel XfconfChannel; + +GType xfconf_channel_get_type() G_GNUC_CONST; + +XfconfChannel *xfconf_channel_get(const gchar *channel_name); + +XfconfChannel *xfconf_channel_new(const gchar *channel_name) G_GNUC_WARN_UNUSED_RESULT; + +XfconfChannel *xfconf_channel_new_with_property_base(const gchar *channel_name, + const gchar *property_base) G_GNUC_WARN_UNUSED_RESULT; + +gboolean xfconf_channel_has_property(XfconfChannel *channel, + const gchar *property); + +gboolean xfconf_channel_is_property_locked(XfconfChannel *channel, + const gchar *property); + +void xfconf_channel_reset_property(XfconfChannel *channel, + const gchar *property_base, + gboolean recursive); + +GHashTable *xfconf_channel_get_properties(XfconfChannel *channel, + const gchar *property_base) G_GNUC_WARN_UNUSED_RESULT; + +/* basic types */ + +gchar *xfconf_channel_get_string(XfconfChannel *channel, + const gchar *property, + const gchar *default_value) G_GNUC_WARN_UNUSED_RESULT; +gboolean xfconf_channel_set_string(XfconfChannel *channel, + const gchar *property, + const gchar *value); + +gint32 xfconf_channel_get_int(XfconfChannel *channel, + const gchar *property, + gint32 default_value); +gboolean xfconf_channel_set_int(XfconfChannel *channel, + const gchar *property, + gint32 value); + +guint32 xfconf_channel_get_uint(XfconfChannel *channel, + const gchar *property, + guint32 default_value); +gboolean xfconf_channel_set_uint(XfconfChannel *channel, + const gchar *property, + guint32 value); + +guint64 xfconf_channel_get_uint64(XfconfChannel *channel, + const gchar *property, + guint64 default_value); +gboolean xfconf_channel_set_uint64(XfconfChannel *channel, + const gchar *property, + guint64 value); + +gdouble xfconf_channel_get_double(XfconfChannel *channel, + const gchar *property, + gdouble default_value); +gboolean xfconf_channel_set_double(XfconfChannel *channel, + const gchar *property, + gdouble value); + +gboolean xfconf_channel_get_bool(XfconfChannel *channel, + const gchar *property, + gboolean default_value); +gboolean xfconf_channel_set_bool(XfconfChannel *channel, + const gchar *property, + gboolean value); + +/* this is just convenience API for the array stuff, where + * all the values are G_TYPE_STRING */ +gchar **xfconf_channel_get_string_list(XfconfChannel *channel, + const gchar *property) G_GNUC_WARN_UNUSED_RESULT; +gboolean xfconf_channel_set_string_list(XfconfChannel *channel, + const gchar *property, + const gchar * const *values); + +/* really generic API - can set some value types that aren't + * supported by the basic type API, e.g., char, signed short, + * unsigned int, etc. no, you can't set arbitrary GTypes. */ +gboolean xfconf_channel_get_property(XfconfChannel *channel, + const gchar *property, + GValue *value); +gboolean xfconf_channel_set_property(XfconfChannel *channel, + const gchar *property, + const GValue *value); + +/* array types - arrays can be made up of values of arbitrary + * (and mixed) types, even some not supported by the basic + * type API */ + +gboolean xfconf_channel_get_array(XfconfChannel *channel, + const gchar *property, + GType first_value_type, + ...); +gboolean xfconf_channel_get_array_valist(XfconfChannel *channel, + const gchar *property, + GType first_value_type, + va_list var_args); +GPtrArray *xfconf_channel_get_arrayv(XfconfChannel *channel, + const gchar *property) G_GNUC_WARN_UNUSED_RESULT; + +gboolean xfconf_channel_set_array(XfconfChannel *channel, + const gchar *property, + GType first_value_type, + ...); +gboolean xfconf_channel_set_array_valist(XfconfChannel *channel, + const gchar *property, + GType first_value_type, + va_list var_args); +gboolean xfconf_channel_set_arrayv(XfconfChannel *channel, + const gchar *property, + GPtrArray *values); + +/* struct types */ + +gboolean xfconf_channel_get_named_struct(XfconfChannel *channel, + const gchar *property, + const gchar *struct_name, + gpointer value_struct); +gboolean xfconf_channel_set_named_struct(XfconfChannel *channel, + const gchar *property, + const gchar *struct_name, + gpointer value_struct); + +gboolean xfconf_channel_get_struct(XfconfChannel *channel, + const gchar *property, + gpointer value_struct, + GType first_member_type, + ...); +gboolean xfconf_channel_get_struct_valist(XfconfChannel *channel, + const gchar *property, + gpointer value_struct, + GType first_member_type, + va_list var_args); +gboolean xfconf_channel_get_structv(XfconfChannel *channel, + const gchar *property, + gpointer value_struct, + guint n_members, + GType *member_types); + +gboolean xfconf_channel_set_struct(XfconfChannel *channel, + const gchar *property, + const gpointer value_struct, + GType first_member_type, + ...); +gboolean xfconf_channel_set_struct_valist(XfconfChannel *channel, + const gchar *property, + const gpointer value_struct, + GType first_member_type, + va_list var_args); +gboolean xfconf_channel_set_structv(XfconfChannel *channel, + const gchar *property, + const gpointer value_struct, + guint n_members, + GType *member_types); + +#if 0 /* future (maybe) */ + +//gboolean xfconf_channel_begin_transaction(XfconfChannel *channel); +//gboolean xfconf_channel_commit_transaction(XfconfChannel *channel); +//void xfconf_channel_cancel_transaction(XfconfChannel *channel); + +#endif + +G_END_DECLS + +#endif /* __XFCONF_CHANNEL_H__ */ diff --git a/include/xfconf-errors.h b/include/xfconf-errors.h new file mode 100644 --- /dev/null +++ b/include/xfconf-errors.h @@ -0,0 +1,53 @@ +/* + * xfconf + * + * Copyright (c) 2007 Brian Tarricone + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; version 2 of the License ONLY. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Library General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + */ + +#ifndef __XFCONF_ERRORS_H__ +#define __XFCONF_ERRORS_H__ + +#if !defined(LIBXFCONF_COMPILATION) && !defined(XFCONF_IN_XFCONF_H) +#error "Do not include xfconf-errors.h, as this file may change or disappear in the future. Include instead." +#endif + +#include + +#define XFCONF_TYPE_ERROR (xfconf_error_get_type()) +#define XFCONF_ERROR (xfconf_get_error_quark()) + +G_BEGIN_DECLS + +typedef enum +{ + XFCONF_ERROR_UNKNOWN = 0, + XFCONF_ERROR_CHANNEL_NOT_FOUND, + XFCONF_ERROR_PROPERTY_NOT_FOUND, + XFCONF_ERROR_READ_FAILURE, + XFCONF_ERROR_WRITE_FAILURE, + XFCONF_ERROR_PERMISSION_DENIED, + XFCONF_ERROR_INTERNAL_ERROR, + XFCONF_ERROR_NO_BACKEND, + XFCONF_ERROR_INVALID_PROPERTY, + XFCONF_ERROR_INVALID_CHANNEL, +} XfconfError; + +GType xfconf_error_get_type() G_GNUC_CONST; +GQuark xfconf_get_error_quark(); + +G_END_DECLS + +#endif /* __XFCONF_ERRORS_H__ */ diff --git a/include/xfconf-types.h b/include/xfconf-types.h new file mode 100644 --- /dev/null +++ b/include/xfconf-types.h @@ -0,0 +1,48 @@ +/* + * xfconf + * + * Copyright (c) 2007 Brian Tarricone + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; version 2 of the License ONLY. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Library General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + */ + +#ifndef __XFCONF_TYPES_H__ +#define __XFCONF_TYPES_H__ + +#if !defined(LIBXFCONF_COMPILATION) && !defined(XFCONF_IN_XFCONF_H) +#error "Do not include xfconf-types.h, as this file may change or disappear in the future. Include instead." +#endif + +#include + +#define XFCONF_TYPE_UINT16 (xfconf_uint16_get_type()) +#define XFCONF_TYPE_INT16 (xfconf_int16_get_type()) + +G_BEGIN_DECLS + +GType xfconf_uint16_get_type() G_GNUC_CONST; + +guint16 xfconf_g_value_get_uint16(const GValue *value); +void xfconf_g_value_set_uint16(GValue *value, + guint16 v_uint16); + +GType xfconf_int16_get_type() G_GNUC_CONST; + +gint16 xfconf_g_value_get_int16(const GValue *value); +void xfconf_g_value_set_int16(GValue *value, + gint16 v_int16); + +G_END_DECLS + +#endif diff --git a/include/xfconf.h b/include/xfconf.h new file mode 100644 --- /dev/null +++ b/include/xfconf.h @@ -0,0 +1,49 @@ +/* + * xfconf + * + * Copyright (c) 2007 Brian Tarricone + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; version 2 of the License ONLY. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Library General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + */ + +#ifndef __XFCONF_H__ +#define __XFCONF_H__ + +#include + +#define XFCONF_IN_XFCONF_H + +#include +#include +#include +#include + +#undef XFCONF_IN_XFCONF_H + +G_BEGIN_DECLS + +gboolean xfconf_init(GError **error); +void xfconf_shutdown(); + +void xfconf_named_struct_register(const gchar *struct_name, + guint n_members, + const GType *member_types); + +void xfconf_array_free(GPtrArray *arr); + +gchar **xfconf_list_channels() G_GNUC_WARN_UNUSED_RESULT; + +G_END_DECLS + +#endif /* __XFCONF_H__ */ diff --git a/marshal.list b/marshal.list new file mode 100644 --- /dev/null +++ b/marshal.list @@ -0,0 +1,45 @@ +# see glib-genmarshal(1) for a detailed description of the file format, +# possible parameter types are: +# VOID indicates no return type, or no extra +# parameters. if VOID is used as the parameter +# list, no additional parameters may be present. +# BOOLEAN for boolean types (gboolean) +# CHAR for signed char types (gchar) +# UCHAR for unsigned char types (guchar) +# INT for signed integer types (gint) +# UINT for unsigned integer types (guint) +# LONG for signed long integer types (glong) +# ULONG for unsigned long integer types (gulong) +# ENUM for enumeration types (gint) +# FLAGS for flag enumeration types (guint) +# FLOAT for single-precision float types (gfloat) +# DOUBLE for double-precision float types (gdouble) +# STRING for string types (gchar*) +# BOXED for boxed (anonymous but reference counted) types (GBoxed*) +# POINTER for anonymous pointer types (gpointer) +# NONE deprecated alias for VOID +# BOOL deprecated alias for BOOLEAN + +# +# One discrepancy from Gtk+ is that for signals that may pass NULL for an object +# reference, the Haskell signal should be passed a 'Maybe GObject'. +# We therefore have two variants that are marshalled as a maybe type: +# +# OBJECT for GObject or derived types (GObject*) +# MOBJECT for GObject or derived types (GObject*) that may be NULL + +# Furthermore, some objects needs to be destroyed synchronously from the main loop of +# Gtk rather than during GC. These objects need to be marshalled using TOBJECT (for thread-safe +# object). It doesn't hurt to use TOBJECT for an object that doesn't need it, except for the +# some performance. As a rule of thumb, use TOBJECT for all libraries that build on package +# 'gtk' and use OBJECT for all packages that only need packages 'glib', 'pango', 'cairo', +# 'gio'. Again both variants exist. Note that the same names will be generated for OBJECT and +# TOBJECT, so you have to remove the OBJECT handler if you need both. +# +# TOBJECT for GObject or derived types (GObject*) +# MTOBJECT for GObject or derived types (GObject*) that may be NULL + +# If you add a new signal type, please check that it actually works! +# If it is a Boxed type check that the reference counting is right. + +NONE:STRING,POINTER diff --git a/xfconf.cabal b/xfconf.cabal new file mode 100644 --- /dev/null +++ b/xfconf.cabal @@ -0,0 +1,165 @@ +-- auto-generated by cabal init. For additional options, see: +-- http://www.haskell.org/cabal/release/cabal-latest/doc/users-guide/authors.html#pkg-descr. + +Name: xfconf +Version: 4.8.0.0 +Stability: alpha +Synopsis: FFI bindings to xfconf +Description: + Xfconf is a simple client-server configuration storage and query + system build on top of glib and used by XFCE. +Homepage: http://patch-tag.com/r/obbele/xfconf/home +License: GPL-3 +License-file: LICENSE +Author: John Obbele +Maintainer: john.obbele@gmail.com +Category: System, XFCE +Build-type: Custom +Cabal-version: >=1.6 + +Extra-Source-Files: Gtk2HsSetup.hs marshal.list hierarchy.list +Extra-source-files: Makefile README + +-- Demo program. +Extra-source-files: Demo/Demo.hs + +-- Some examples of native C xfconf. +Extra-source-files: C/demo.c C/Makefile + +-- Header files for reference. +Extra-source-files: include/xfconf-binding.h include/xfconf-channel.h +Extra-source-files: include/xfconf-errors.h include/xfconf.h +Extra-source-files: include/xfconf-types.h + +-- Header files forcing gtk2hsC2hs to include multiple headers. +Extra-source-files: include/all.h + +-- Gtk2HS black magic. +x-Types-File: System/XFCE/Xfconf/Types.chs +x-Types-ModName: System.XFCE.Xfconf.Types +x-Types-Import: System.Glib.GObject +x-Types-Tag: xfconf +x-Types-Hierarchy: hierarchy.list + +Source-Repository head + type: darcs + location: http://patch-tag.com/r/obbele/xfconf/home + +Flag buildTests + description: Build the two test suites + default: False + +library + -- Be a good child and build modules in the following order + -- to avoid dependencies misfortunes. + Exposed-Modules: System.XFCE.Xfconf.Unsafe + System.XFCE.Xfconf.Core + System.XFCE.Xfconf.Error + System.XFCE.Xfconf.Values + -- Channel requires those normally hidden packages + System.XFCE.Xfconf.GHashTable + System.XFCE.Xfconf.Types + System.XFCE.Xfconf.Signals + -- + System.XFCE.Xfconf.Channel + -- Binding requires Channel + System.XFCE.Xfconf.Binding + -- … and in the darkness bind them + System.XFCE.Xfconf + + Other-Modules: System.XFCE.Xfconf.FFI + + Build-depends: base >=3.0 && < 5.0, + glib >=0.12 + + -- dependencies specific to Tests/Tests + if flag(buildTests) + Build-depends: test-framework ==0.3.*, + test-framework-hunit ==0.2.*, + test-framework-quickcheck2 ==0.2.*, + HUnit ==1.2.*, + QuickCheck >=2.1 + + build-tools: gtk2hsC2hs, gtk2hsHookGenerator, gtk2hsTypeGen + + x-Signals-File: System/XFCE/Xfconf/Signals.chs + x-Signals-Modname: System.XFCE.Xfconf.Signals + x-Signals-Types: marshal.list + x-c2hs-Header: include/all.h + -- needed by Types.chs + extensions: ForeignFunctionInterface + + pkgconfig-depends: libxfconf-0 + + ghc-options: -Wall -fno-warn-unused-do-bind + +Executable tests + Main-is: Tests/Tests.hs + + if flag(buildTests) + Buildable: True + else + Buildable: False + + ghc-options: -Wall + ghc-options: -fno-warn-unused-do-bind + ghc-options: -fno-warn-missing-signatures + ghc-options: -auto-all + + -- Copy-and-paste instructions from the previous library target. + build-tools: gtk2hsC2hs, gtk2hsHookGenerator, gtk2hsTypeGen + x-Signals-File: System/XFCE/Xfconf/Signals.chs + x-Signals-Modname: System.XFCE.Xfconf.Signals + x-Signals-Types: marshal.list + x-c2hs-Header: include/all.h + extensions: ForeignFunctionInterface + pkgconfig-depends: libxfconf-0 + -- Cabal refuses to build saying that System.XFCE.Xfconf.{FFI, ...} + -- are hidden modules from the missing dependency "xfconf-0.0.0.x" + -- For peace on earth we shall declare all our previous modules + -- in the following "Other-Modules" attributes + Other-Modules: System.XFCE.Xfconf.FFI + System.XFCE.Xfconf.Unsafe + System.XFCE.Xfconf.Core + System.XFCE.Xfconf.Error + System.XFCE.Xfconf.Values + System.XFCE.Xfconf.GHashTable + System.XFCE.Xfconf.Types + System.XFCE.Xfconf.Signals + System.XFCE.Xfconf.Channel + System.XFCE.Xfconf.Binding + System.XFCE.Xfconf + +Executable testGlib + Main-is: Tests/TestGlib.hs + + if flag(buildTests) + Buildable: True + else + Buildable: False + + ghc-options: -Wall + ghc-options: -fno-warn-unused-do-bind + ghc-options: -fno-warn-missing-signatures + ghc-options: -threaded + + -- Copy-and-paste instructions from the previous library target. + build-tools: gtk2hsC2hs, gtk2hsHookGenerator, gtk2hsTypeGen + x-Signals-File: System/XFCE/Xfconf/Signals.chs + x-Signals-Modname: System.XFCE.Xfconf.Signals + x-Signals-Types: marshal.list + x-c2hs-Header: include/all.h + extensions: ForeignFunctionInterface + pkgconfig-depends: libxfconf-0 + Other-Modules: System.XFCE.Xfconf.FFI + System.XFCE.Xfconf.Unsafe + System.XFCE.Xfconf.Core + System.XFCE.Xfconf.Error + System.XFCE.Xfconf.Values + System.XFCE.Xfconf.GHashTable + System.XFCE.Xfconf.Types + System.XFCE.Xfconf.Signals + System.XFCE.Xfconf.Channel + System.XFCE.Xfconf.Binding + System.XFCE.Xfconf +