glib (empty) → 0.11.0
raw patch · 26 files changed
+4560/−0 lines, 26 filesdep +basedep +containersdep +haskell98build-type:Customsetup-changed
Dependencies added: base, containers, haskell98
Files
- COPYING +504/−0
- Gtk2HsSetup.hs +486/−0
- Setup.hs +7/−0
- System/Glib.hs +23/−0
- System/Glib/Attributes.hs +159/−0
- System/Glib/FFI.hs +89/−0
- System/Glib/Flags.hs +76/−0
- System/Glib/GDateTime.chs +347/−0
- System/Glib/GError.chs +264/−0
- System/Glib/GList.chs +146/−0
- System/Glib/GObject.chs +209/−0
- System/Glib/GParameter.hsc +49/−0
- System/Glib/GType.chs +47/−0
- System/Glib/GTypeConstants.hsc +63/−0
- System/Glib/GValue.chs +68/−0
- System/Glib/GValueTypes.chs +225/−0
- System/Glib/MainLoop.chs +348/−0
- System/Glib/Properties.chs +347/−0
- System/Glib/Signals.chs +213/−0
- System/Glib/StoreValue.hsc +161/−0
- System/Glib/Types.chs +69/−0
- System/Glib/UTFString.hs +210/−0
- System/Glib/Utils.chs +80/−0
- System/Glib/hsgclosure.c +281/−0
- System/Glib/hsgclosure.h +22/−0
- glib.cabal +67/−0
+ COPYING view
@@ -0,0 +1,504 @@+ GNU LESSER GENERAL PUBLIC LICENSE+ Version 2.1, February 1999++ Copyright (C) 1991, 1999 Free Software Foundation, Inc.+ 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA+ Everyone is permitted to copy and distribute verbatim copies+ of this license document, but changing it is not allowed.++[This is the first released version of the Lesser GPL. It also counts+ as the successor of the GNU Library Public License, version 2, hence+ the version number 2.1.]++ Preamble++ The licenses for most software are designed to take away your+freedom to share and change it. By contrast, the GNU General Public+Licenses are intended to guarantee your freedom to share and change+free software--to make sure the software is free for all its users.++ This license, the Lesser General Public License, applies to some+specially designated software packages--typically libraries--of the+Free Software Foundation and other authors who decide to use it. You+can use it too, but we suggest you first think carefully about whether+this license or the ordinary General Public License is the better+strategy to use in any particular case, based on the explanations below.++ When we speak of free software, we are referring to freedom of use,+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 this service if you wish); that you receive source code or can get+it if you want it; that you can change the software and use pieces of+it in new free programs; and that you are informed that you can do+these things.++ To protect your rights, we need to make restrictions that forbid+distributors to deny you these rights or to ask you to surrender these+rights. These restrictions translate to certain responsibilities for+you if you distribute copies of the library or if you modify it.++ For example, if you distribute copies of the library, whether gratis+or for a fee, you must give the recipients all the rights that we gave+you. You must make sure that they, too, receive or can get the source+code. If you link other code with the library, you must provide+complete object files to the recipients, so that they can relink them+with the library after making changes to the library and recompiling+it. And you must show them these terms so they know their rights.++ We protect your rights with a two-step method: (1) we copyright the+library, and (2) we offer you this license, which gives you legal+permission to copy, distribute and/or modify the library.++ To protect each distributor, we want to make it very clear that+there is no warranty for the free library. Also, if the library is+modified by someone else and passed on, the recipients should know+that what they have is not the original version, so that the original+author's reputation will not be affected by problems that might be+introduced by others.++ Finally, software patents pose a constant threat to the existence of+any free program. We wish to make sure that a company cannot+effectively restrict the users of a free program by obtaining a+restrictive license from a patent holder. Therefore, we insist that+any patent license obtained for a version of the library must be+consistent with the full freedom of use specified in this license.++ Most GNU software, including some libraries, is covered by the+ordinary GNU General Public License. This license, the GNU Lesser+General Public License, applies to certain designated libraries, and+is quite different from the ordinary General Public License. We use+this license for certain libraries in order to permit linking those+libraries into non-free programs.++ When a program is linked with a library, whether statically or using+a shared library, the combination of the two is legally speaking a+combined work, a derivative of the original library. The ordinary+General Public License therefore permits such linking only if the+entire combination fits its criteria of freedom. The Lesser General+Public License permits more lax criteria for linking other code with+the library.++ We call this license the "Lesser" General Public License because it+does Less to protect the user's freedom than the ordinary General+Public License. It also provides other free software developers Less+of an advantage over competing non-free programs. These disadvantages+are the reason we use the ordinary General Public License for many+libraries. However, the Lesser license provides advantages in certain+special circumstances.++ For example, on rare occasions, there may be a special need to+encourage the widest possible use of a certain library, so that it becomes+a de-facto standard. To achieve this, non-free programs must be+allowed to use the library. A more frequent case is that a free+library does the same job as widely used non-free libraries. In this+case, there is little to gain by limiting the free library to free+software only, so we use the Lesser General Public License.++ In other cases, permission to use a particular library in non-free+programs enables a greater number of people to use a large body of+free software. For example, permission to use the GNU C Library in+non-free programs enables many more people to use the whole GNU+operating system, as well as its variant, the GNU/Linux operating+system.++ Although the Lesser General Public License is Less protective of the+users' freedom, it does ensure that the user of a program that is+linked with the Library has the freedom and the wherewithal to run+that program using a modified version of the Library.++ The precise terms and conditions for copying, distribution and+modification follow. Pay close attention to the difference between a+"work based on the library" and a "work that uses the library". The+former contains code derived from the library, whereas the latter must+be combined with the library in order to run.++ GNU LESSER GENERAL PUBLIC LICENSE+ TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION++ 0. This License Agreement applies to any software library or other+program which contains a notice placed by the copyright holder or+other authorized party saying it may be distributed under the terms of+this Lesser General Public License (also called "this License").+Each licensee is addressed as "you".++ A "library" means a collection of software functions and/or data+prepared so as to be conveniently linked with application programs+(which use some of those functions and data) to form executables.++ The "Library", below, refers to any such software library or work+which has been distributed under these terms. A "work based on the+Library" means either the Library or any derivative work under+copyright law: that is to say, a work containing the Library or a+portion of it, either verbatim or with modifications and/or translated+straightforwardly into another language. (Hereinafter, translation is+included without limitation in the term "modification".)++ "Source code" for a work means the preferred form of the work for+making modifications to it. For a library, complete source code means+all the source code for all modules it contains, plus any associated+interface definition files, plus the scripts used to control compilation+and installation of the library.++ Activities other than copying, distribution and modification are not+covered by this License; they are outside its scope. The act of+running a program using the Library is not restricted, and output from+such a program is covered only if its contents constitute a work based+on the Library (independent of the use of the Library in a tool for+writing it). Whether that is true depends on what the Library does+and what the program that uses the Library does.+ + 1. You may copy and distribute verbatim copies of the Library's+complete source code as you receive it, in any medium, provided that+you conspicuously and appropriately publish on each copy an+appropriate copyright notice and disclaimer of warranty; keep intact+all the notices that refer to this License and to the absence of any+warranty; and distribute a copy of this License along with the+Library.++ You may charge a fee for the physical act of transferring a copy,+and you may at your option offer warranty protection in exchange for a+fee.++ 2. You may modify your copy or copies of the Library or any portion+of it, thus forming a work based on the Library, and copy and+distribute such modifications or work under the terms of Section 1+above, provided that you also meet all of these conditions:++ a) The modified work must itself be a software library.++ b) You must cause the files modified to carry prominent notices+ stating that you changed the files and the date of any change.++ c) You must cause the whole of the work to be licensed at no+ charge to all third parties under the terms of this License.++ d) If a facility in the modified Library refers to a function or a+ table of data to be supplied by an application program that uses+ the facility, other than as an argument passed when the facility+ is invoked, then you must make a good faith effort to ensure that,+ in the event an application does not supply such function or+ table, the facility still operates, and performs whatever part of+ its purpose remains meaningful.++ (For example, a function in a library to compute square roots has+ a purpose that is entirely well-defined independent of the+ application. Therefore, Subsection 2d requires that any+ application-supplied function or table used by this function must+ be optional: if the application does not supply it, the square+ root function must still compute square roots.)++These requirements apply to the modified work as a whole. If+identifiable sections of that work are not derived from the Library,+and can be reasonably considered independent and separate works in+themselves, then this License, and its terms, do not apply to those+sections when you distribute them as separate works. But when you+distribute the same sections as part of a whole which is a work based+on the Library, the distribution of the whole must be on the terms of+this License, whose permissions for other licensees extend to the+entire whole, and thus to each and every part regardless of who wrote+it.++Thus, it is not the intent of this section to claim rights or contest+your rights to work written entirely by you; rather, the intent is to+exercise the right to control the distribution of derivative or+collective works based on the Library.++In addition, mere aggregation of another work not based on the Library+with the Library (or with a work based on the Library) on a volume of+a storage or distribution medium does not bring the other work under+the scope of this License.++ 3. You may opt to apply the terms of the ordinary GNU General Public+License instead of this License to a given copy of the Library. To do+this, you must alter all the notices that refer to this License, so+that they refer to the ordinary GNU General Public License, version 2,+instead of to this License. (If a newer version than version 2 of the+ordinary GNU General Public License has appeared, then you can specify+that version instead if you wish.) Do not make any other change in+these notices.++ Once this change is made in a given copy, it is irreversible for+that copy, so the ordinary GNU General Public License applies to all+subsequent copies and derivative works made from that copy.++ This option is useful when you wish to copy part of the code of+the Library into a program that is not a library.++ 4. You may copy and distribute the Library (or a portion or+derivative of it, under Section 2) in object code or executable form+under the terms of Sections 1 and 2 above provided that you accompany+it with the complete corresponding machine-readable source code, which+must be distributed under the terms of Sections 1 and 2 above on a+medium customarily used for software interchange.++ If distribution of object code is made by offering access to copy+from a designated place, then offering equivalent access to copy the+source code from the same place satisfies the requirement to+distribute the source code, even though third parties are not+compelled to copy the source along with the object code.++ 5. A program that contains no derivative of any portion of the+Library, but is designed to work with the Library by being compiled or+linked with it, is called a "work that uses the Library". Such a+work, in isolation, is not a derivative work of the Library, and+therefore falls outside the scope of this License.++ However, linking a "work that uses the Library" with the Library+creates an executable that is a derivative of the Library (because it+contains portions of the Library), rather than a "work that uses the+library". The executable is therefore covered by this License.+Section 6 states terms for distribution of such executables.++ When a "work that uses the Library" uses material from a header file+that is part of the Library, the object code for the work may be a+derivative work of the Library even though the source code is not.+Whether this is true is especially significant if the work can be+linked without the Library, or if the work is itself a library. The+threshold for this to be true is not precisely defined by law.++ If such an object file uses only numerical parameters, data+structure layouts and accessors, and small macros and small inline+functions (ten lines or less in length), then the use of the object+file is unrestricted, regardless of whether it is legally a derivative+work. (Executables containing this object code plus portions of the+Library will still fall under Section 6.)++ Otherwise, if the work is a derivative of the Library, you may+distribute the object code for the work under the terms of Section 6.+Any executables containing that work also fall under Section 6,+whether or not they are linked directly with the Library itself.++ 6. As an exception to the Sections above, you may also combine or+link a "work that uses the Library" with the Library to produce a+work containing portions of the Library, and distribute that work+under terms of your choice, provided that the terms permit+modification of the work for the customer's own use and reverse+engineering for debugging such modifications.++ You must give prominent notice with each copy of the work that the+Library is used in it and that the Library and its use are covered by+this License. You must supply a copy of this License. If the work+during execution displays copyright notices, you must include the+copyright notice for the Library among them, as well as a reference+directing the user to the copy of this License. Also, you must do one+of these things:++ a) Accompany the work with the complete corresponding+ machine-readable source code for the Library including whatever+ changes were used in the work (which must be distributed under+ Sections 1 and 2 above); and, if the work is an executable linked+ with the Library, with the complete machine-readable "work that+ uses the Library", as object code and/or source code, so that the+ user can modify the Library and then relink to produce a modified+ executable containing the modified Library. (It is understood+ that the user who changes the contents of definitions files in the+ Library will not necessarily be able to recompile the application+ to use the modified definitions.)++ b) Use a suitable shared library mechanism for linking with the+ Library. A suitable mechanism is one that (1) uses at run time a+ copy of the library already present on the user's computer system,+ rather than copying library functions into the executable, and (2)+ will operate properly with a modified version of the library, if+ the user installs one, as long as the modified version is+ interface-compatible with the version that the work was made with.++ c) Accompany the work with a written offer, valid for at+ least three years, to give the same user the materials+ specified in Subsection 6a, above, for a charge no more+ than the cost of performing this distribution.++ d) If distribution of the work is made by offering access to copy+ from a designated place, offer equivalent access to copy the above+ specified materials from the same place.++ e) Verify that the user has already received a copy of these+ materials or that you have already sent this user a copy.++ For an executable, the required form of the "work that uses the+Library" must include any data and utility programs needed for+reproducing the executable from it. However, as a special exception,+the materials to be distributed need not include anything that is+normally distributed (in either source or binary form) with the major+components (compiler, kernel, and so on) of the operating system on+which the executable runs, unless that component itself accompanies+the executable.++ It may happen that this requirement contradicts the license+restrictions of other proprietary libraries that do not normally+accompany the operating system. Such a contradiction means you cannot+use both them and the Library together in an executable that you+distribute.++ 7. You may place library facilities that are a work based on the+Library side-by-side in a single library together with other library+facilities not covered by this License, and distribute such a combined+library, provided that the separate distribution of the work based on+the Library and of the other library facilities is otherwise+permitted, and provided that you do these two things:++ a) Accompany the combined library with a copy of the same work+ based on the Library, uncombined with any other library+ facilities. This must be distributed under the terms of the+ Sections above.++ b) Give prominent notice with the combined library of the fact+ that part of it is a work based on the Library, and explaining+ where to find the accompanying uncombined form of the same work.++ 8. You may not copy, modify, sublicense, link with, or distribute+the Library except as expressly provided under this License. Any+attempt otherwise to copy, modify, sublicense, link with, or+distribute the Library is void, and will automatically terminate your+rights under this License. However, parties who have received copies,+or rights, from you under this License will not have their licenses+terminated so long as such parties remain in full compliance.++ 9. You are not required to accept this License, since you have not+signed it. However, nothing else grants you permission to modify or+distribute the Library or its derivative works. These actions are+prohibited by law if you do not accept this License. Therefore, by+modifying or distributing the Library (or any work based on the+Library), you indicate your acceptance of this License to do so, and+all its terms and conditions for copying, distributing or modifying+the Library or works based on it.++ 10. Each time you redistribute the Library (or any work based on the+Library), the recipient automatically receives a license from the+original licensor to copy, distribute, link with or modify the Library+subject to these terms and conditions. You may not impose any further+restrictions on the recipients' exercise of the rights granted herein.+You are not responsible for enforcing compliance by third parties with+this License.++ 11. If, as a consequence of a court judgment or allegation of patent+infringement or for any other reason (not limited to patent issues),+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+distribute so as to satisfy simultaneously your obligations under this+License and any other pertinent obligations, then as a consequence you+may not distribute the Library at all. For example, if a patent+license would not permit royalty-free redistribution of the Library by+all those who receive copies directly or indirectly through you, then+the only way you could satisfy both it and this License would be to+refrain entirely from distribution of the Library.++If any portion of this section is held invalid or unenforceable under any+particular circumstance, the balance of the section is intended to apply,+and the section as a whole is intended to apply in other circumstances.++It is not the purpose of this section to induce you to infringe any+patents or other property right claims or to contest validity of any+such claims; this section has the sole purpose of protecting the+integrity of the free software distribution system which is+implemented by public license practices. Many people have made+generous contributions to the wide range of software distributed+through that system in reliance on consistent application of that+system; it is up to the author/donor to decide if he or she is willing+to distribute software through any other system and a licensee cannot+impose that choice.++This section is intended to make thoroughly clear what is believed to+be a consequence of the rest of this License.++ 12. If the distribution and/or use of the Library is restricted in+certain countries either by patents or by copyrighted interfaces, the+original copyright holder who places the Library under this License may add+an explicit geographical distribution limitation excluding those countries,+so that distribution is permitted only in or among countries not thus+excluded. In such case, this License incorporates the limitation as if+written in the body of this License.++ 13. The Free Software Foundation may publish revised and/or new+versions of the Lesser 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 Library+specifies a version number of this License which applies to it and+"any later version", you have the option of following the terms and+conditions either of that version or of any later version published by+the Free Software Foundation. If the Library does not specify a+license version number, you may choose any version ever published by+the Free Software Foundation.++ 14. If you wish to incorporate parts of the Library into other free+programs whose distribution conditions are incompatible with these,+write to the author to ask for permission. For software which is+copyrighted by the Free Software Foundation, write to the Free+Software Foundation; we sometimes make exceptions for this. Our+decision will be guided by the two goals of preserving the free status+of all derivatives of our free software and of promoting the sharing+and reuse of software generally.++ NO WARRANTY++ 15. BECAUSE THE LIBRARY IS LICENSED FREE OF CHARGE, THERE IS NO+WARRANTY FOR THE LIBRARY, TO THE EXTENT PERMITTED BY APPLICABLE LAW.+EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR+OTHER PARTIES PROVIDE THE LIBRARY "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+LIBRARY IS WITH YOU. SHOULD THE LIBRARY PROVE DEFECTIVE, YOU ASSUME+THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION.++ 16. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN+WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY+AND/OR REDISTRIBUTE THE LIBRARY 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+LIBRARY (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 LIBRARY TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF+SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH+DAMAGES.++ END OF TERMS AND CONDITIONS++ How to Apply These Terms to Your New Libraries++ If you develop a new library, and you want it to be of the greatest+possible use to the public, we recommend making it free software that+everyone can redistribute and change. You can do so by permitting+redistribution under these terms (or, alternatively, under the terms of the+ordinary General Public License).++ To apply these terms, attach the following notices to the library. It is+safest to attach them to the start of each source file to most effectively+convey the exclusion of warranty; and each file should have at least the+"copyright" line and a pointer to where the full notice is found.++ <one line to give the library's name and a brief idea of what it does.>+ Copyright (C) <year> <name of author>++ 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.++ You should have received a copy of the GNU Lesser General Public+ License along with this library; if not, write to the Free Software+ Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA++Also add information on how to contact you by electronic and paper mail.++You should also get your employer (if you work as a programmer) or your+school, if any, to sign a "copyright disclaimer" for the library, if+necessary. Here is a sample; alter the names:++ Yoyodyne, Inc., hereby disclaims all copyright interest in the+ library `Frob' (a library for tweaking knobs) written by James Random Hacker.++ <signature of Ty Coon>, 1 April 1990+ Ty Coon, President of Vice++That's all there is to it!++
+ Gtk2HsSetup.hs view
@@ -0,0 +1,486 @@+{-# 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__ >= 612)+#define CABAL_VERSION CABAL_VERSION_ENCODE(1,8,0)+#else+#define CABAL_VERSION CABAL_VERSION_ENCODE(1,6,0)+#endif+#endif++-- | Build a Gtk2hs package.+--+module Gtk2HsSetup ( gtk2hsUserHooks, getPkgConfigPackages ) 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,+ 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.Directory ( doesFileExist )+import Distribution.Version (Version(..))+import Distribution.Verbosity+import Control.Monad (when, unless, filterM)+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 ((<$>))+import System.Directory (getDirectoryContents, doesDirectoryExist)++-- the name of the c2hs pre-compiled header file+precompFile = "precompchs.bin"++gtk2hsUserHooks = simpleUserHooks {+ hookedPrograms = [typeGenProgram, signalGenProgram, c2hsLocal],+ hookedPreProcessors = [("chs", ourC2hs)],+ confHook = \pd cf ->+ confHook simpleUserHooks pd cf >>= return . adjustLocalBuildInfo,+ 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+ installedPkgInfo pkg lbi inplace packageDb++ 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])+ (map 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++ (flip mapM_) (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 "<no file>" . 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 } = withFileContents 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)
+ Setup.hs view
@@ -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
+ System/Glib.hs view
@@ -0,0 +1,23 @@++module System.Glib (+ module System.Glib.UTFString,+ module System.Glib.GType,+ module System.Glib.GValueTypes,+ module System.Glib.GObject,+ module System.Glib.GParameter,+ module System.Glib.GError,+ module System.Glib.GList,+ module System.Glib.GDateTime,+ module System.Glib.Utils+ ) where++import System.Glib.UTFString+import System.Glib.GType+import System.Glib.GValueTypes+import System.Glib.GObject+import System.Glib.GParameter+import System.Glib.GError+import System.Glib.GList+import System.Glib.GDateTime+import System.Glib.Utils+-- do not import System.Glib.FFI
+ System/Glib/Attributes.hs view
@@ -0,0 +1,159 @@+{-# LANGUAGE ExistentialQuantification #-}+-- -*-haskell-*-+-- GIMP Toolkit (GTK) Attributes interface+--+-- Author : Duncan Coutts+--+-- Created: 21 January 2005+--+-- Copyright (C) 2005 Duncan Coutts+--+-- Partially derived from the hs-fltk and wxHaskell projects which+-- are both under LGPL compatible licenses.+--+-- 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.+--+-- |+-- Maintainer : gtk2hs-users@lists.sourceforge.net+-- Stability : experimental+-- Portability : portable+--+-- Attributes interface+--+-- Attributes of an object can be get and set. Getting the value of an+-- object's attribute is straingtforward. As an example consider a @button@+-- widget and an attribute called @buttonLabel@.+--+-- > value <- get button buttonLabel+--+-- The syntax for setting or updating an attribute is only slightly more+-- complex. At the simplest level it is just:+--+-- > set button [ buttonLabel := value ]+--+-- However as the list notation would indicate, you can set or update multiple+-- attributes of the same object in one go:+--+-- > set button [ buttonLabel := value, buttonFocusOnClick := False ]+--+-- You are not limited to setting the value of an attribute, you can also+-- apply an update function to an attribute's value. That is the function+-- receives the current value of the attribute and returns the new value.+--+-- > set spinButton [ spinButtonValue :~ (+1) ]+--+-- There are other variants of these operators, (see 'AttrOp'). ':=>' and+-- ':~>' and like ':=' and ':~' but operate in the 'IO' monad rather+-- than being pure. There is also '::=' and '::~' which take the object+-- as an extra parameter.+--+-- Attributes can be read only, write only or both read\/write.+--+module System.Glib.Attributes (+ -- * Attribute types+ Attr,+ ReadAttr,+ WriteAttr,+ ReadWriteAttr,++ -- * Interface for getting, setting and updating attributes+ AttrOp(..),+ get,+ set,+ + -- * Internal attribute constructors+ newNamedAttr,+ readNamedAttr,+ writeNamedAttr,+ newAttr,+ readAttr,+ writeAttr,+ ) where++infixr 0 :=,:~,:=>,:~>,::=,::~++-- | An ordinary attribute. Most attributes have the same get and set types.+type Attr o a = ReadWriteAttr o a a++-- | A read-only attribute.+type ReadAttr o a = ReadWriteAttr o a ()++-- | A write-only attribute.+type WriteAttr o b = ReadWriteAttr o () b++-- | A generalised attribute with independent get and set types.+data ReadWriteAttr o a b = Attr String !(o -> IO a) !(o -> b -> IO ())++instance Show (ReadWriteAttr o a b) where+ show (Attr str _ _) = str++-- | Create a new attribute with a getter and setter function.+newNamedAttr :: String -> (o -> IO a) -> (o -> b -> IO ()) -> ReadWriteAttr o a b+newNamedAttr prop getter setter = Attr prop getter setter++-- | Create a new read-only attribute.+readNamedAttr :: String -> (o -> IO a) -> ReadAttr o a+readNamedAttr prop getter = Attr prop getter (\_ _ -> return ())++-- | Create a new write-only attribute.+writeNamedAttr :: String -> (o -> b -> IO ()) -> WriteAttr o b+writeNamedAttr prop setter = Attr prop (\_ -> return ()) setter++-- | Create a new attribute with a getter and setter function.+newAttr :: (o -> IO a) -> (o -> b -> IO ()) -> ReadWriteAttr o a b+newAttr getter setter = Attr "unnamed attribute" getter setter++-- | Create a new read-only attribute.+readAttr :: (o -> IO a) -> ReadAttr o a+readAttr getter = Attr "unnamed attribute" getter (\_ _ -> return ())++-- | Create a new write-only attribute.+writeAttr :: (o -> b -> IO ()) -> WriteAttr o b+writeAttr setter = Attr "unnamed attribute" (\_ -> return ()) setter++-- | A set or update operation on an attribute.+data AttrOp o+ = forall a b.+ ReadWriteAttr o a b := b -- ^ Assign a value to an+ -- attribute.+ | forall a b.+ ReadWriteAttr o a b :~ ( a -> b) -- ^ Apply an update function to+ -- an attribute.+ | forall a b.+ ReadWriteAttr o a b :=> ( IO b) -- ^ Assign the result of an IO+ -- action to an attribute.+ | forall a b.+ ReadWriteAttr o a b :~> ( a -> IO b) -- ^ Apply a IO update function+ -- to an attribute.+ | forall a b.+ ReadWriteAttr o a b ::= (o -> b) -- ^ Assign a value to an+ -- attribute with the object as+ -- an argument.+ | forall a b.+ ReadWriteAttr o a b ::~ (o -> a -> b) -- ^ Apply an update function to+ -- an attribute with the object+ -- as an argument.++-- | Set a number of properties for some object.+set :: o -> [AttrOp o] -> IO ()+set obj = mapM_ app+ where+ app (Attr _ getter setter := x) = setter obj x+ app (Attr _ getter setter :~ f) = getter obj >>= \v -> setter obj (f v)+ app (Attr _ getter setter :=> x) = x >>= setter obj+ app (Attr _ getter setter :~> f) = getter obj >>= f >>= setter obj++ app (Attr _ getter setter ::= f) = setter obj (f obj)+ app (Attr _ getter setter ::~ f) = getter obj >>= \v -> setter obj (f obj v)++-- | Get an Attr of an object.+get :: o -> ReadWriteAttr o a b -> IO a+get o (Attr _ getter setter) = getter o
+ System/Glib/FFI.hs view
@@ -0,0 +1,89 @@+{-# LANGUAGE CPP #-}+{-# OPTIONS_HADDOCK hide #-}+-- GIMP Toolkit (GTK) FFI extras and version dependencies+--+-- Author : Axel Simon+--+-- Created: 22 June 2001+--+-- Copyright (C) 1999-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++-- |+--+-- This module serves as an impedance matcher for different compiler+-- versions. It also adds a few FFI utility functions.+--++module System.Glib.FFI (+ with,+ nullForeignPtr,+ maybeNull,+ newForeignPtr,+ withForeignPtrs,+ module Foreign,+ module Foreign.C+ ) where++import System.IO.Unsafe (unsafePerformIO)++-- We should almost certainly not be using the standard free function anywhere+-- in the glib or gtk bindings, so we do not re-export it from this module.++import Foreign.C+import qualified Foreign hiding (free)+import Foreign hiding (with, newForeignPtr, free+#if (__GLASGOW_HASKELL__<606)+ , withObject+#endif+ )+#if (__GLASGOW_HASKELL__>=610)+import qualified Foreign.Concurrent+#endif++with :: (Storable a) => a -> (Ptr a -> IO b) -> IO b+with = Foreign.with++#if (__GLASGOW_HASKELL__>=610)+newForeignPtr :: Ptr a -> FinalizerPtr a -> IO (ForeignPtr a)+newForeignPtr p finalizer+ = Foreign.Concurrent.newForeignPtr p (mkFinalizer finalizer p)++foreign import ccall "dynamic"+ mkFinalizer :: FinalizerPtr a -> Ptr a -> IO ()+#else+newForeignPtr :: Ptr a -> FinalizerPtr a -> IO (ForeignPtr a)+newForeignPtr = flip Foreign.newForeignPtr+#endif++nullForeignPtr :: ForeignPtr a+nullForeignPtr = unsafePerformIO $ newForeignPtr_ nullPtr++-- This is useful when it comes to marshaling lists of GObjects+--+withForeignPtrs :: [ForeignPtr a] -> ([Ptr a] -> IO b) -> IO b+withForeignPtrs fptrs body = do+ result <- body (map unsafeForeignPtrToPtr fptrs)+ mapM_ touchForeignPtr fptrs+ return result++-- A marshaling utility function that is used by the code produced by the code+-- generator to marshal return values that can be null+maybeNull :: (IO (Ptr a) -> IO a) -> IO (Ptr a) -> IO (Maybe a)+maybeNull marshal genPtr = do+ ptr <- genPtr+ if ptr == nullPtr+ then return Nothing+ else do result <- marshal (return ptr)+ return (Just result)
+ System/Glib/Flags.hs view
@@ -0,0 +1,76 @@+-- -*-haskell-*-+-- class of flag types+--+-- Author : Duncan Coutts+--+-- Created: 21 January 2005+--+-- Copyright (C) 2001-2005 Duncan Coutts, 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.+--+-- |+-- Maintainer : gtk2hs-users@lists.sourceforge.net+-- Stability : provisional+-- Portability : portable+--+-- This module defines a type class for flags that are marshaled as bitflags.+--+module System.Glib.Flags (+ Flags,+ fromFlags,+ toFlags+ ) where++import Data.Bits ((.|.), (.&.), testBit, shiftL, shiftR)+import Data.Maybe (catMaybes)++class (Enum a, Bounded a) => Flags a+ +fromFlags :: Flags a => [a] -> Int+fromFlags is = orNum 0 is+ where orNum n [] = n+ orNum n (i:is) = orNum (n .|. fromEnum i) is++-- * Note that this function ignores bits set in the passed+-- 'Int' that do not correspond to a flag.+toFlags :: Flags a => Int -> [a]+toFlags n = catMaybes [ if n .&. fromEnum flag == fromEnum flag+ then Just flag+ else Nothing+ | flag <- [minBound .. maxBound] ]++-------------------------+-- QuickCheck test code++{-+import Test.QuickCheck+import List (sort, nub)+-- to run these tests you must copy EventMask and its Enum instance here+-- and make it an instance of Ord, Eq and Show.++prop_ToFlagsFromFlags :: Int -> Property+prop_ToFlagsFromFlags n =+ (n >= 1 && n <= 21)+ ==>+ collect n $+ let flag :: [EventMask]+ flag = toFlags (2^n)+ in 2^n == fromFlags flag++prop_FromFlagsToFlags :: [EventMask] -> Bool+prop_FromFlagsToFlags flags =+ (nub . sort) flags == toFlags (fromFlags flags)++instance Arbitrary EventMask where+ arbitrary = sized $ \_ -> do x <- choose (1,21 :: Int)+ return (toEnum $ 2^x)+-}
+ System/Glib/GDateTime.chs view
@@ -0,0 +1,347 @@+{-# LANGUAGE CPP #-}+-- -*-haskell-*-+-- GIMP Toolkit (GTK)+--+-- Author : Peter Gavin+--+-- Created: July 2007+--+-- Copyright (C) 2007 Peter Gavin +--+-- 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.+--+-- |+-- Maintainer : gtk2hs-users@lists.sourceforge.net+-- Stability : provisional+-- Portability : portable (depends on GHC)+--+module System.Glib.GDateTime (+ GTimeValPart,+ GTimeVal(..),+ gGetCurrentTime,+ gUSleep,+ gTimeValAdd,+#if GLIB_CHECK_VERSION(2,12,0)+ gTimeValFromISO8601,+ gTimeValToISO8601,+#endif+ GDate(..),+ GDateDay,+ GDateMonth,+ GDateYear,+ GDateJulianDay,+ GDateWeekday,+ gDateValidJulian,+ gDateValidDMY,+ gDateNewJulian,+ gDateNewDMY,+ gDateSetDay,+ gDateSetMonth,+ gDateSetYear,+#if GLIB_CHECK_VERSION(2,10,0)+ gDateNewTimeVal,+#endif+ gDateParse,+ gDateAddDays,+ gDateSubtractDays,+ gDateAddMonths,+ gDateSubtractMonths,+ gDateAddYears,+ gDateSubtractYears,+ gDateDaysBetween,+ gDateCompare,+ gDateClamp,+ gDateDay,+ gDateMonth,+ gDateYear,+ gDateWeekday+ ) where++import Control.Monad (liftM)+import System.Glib.FFI+import System.Glib.UTFString++type GTimeValPart = {# type glong #}+data GTimeVal = GTimeVal { gTimeValSec :: GTimeValPart+ , gTimeValUSec :: GTimeValPart }+ deriving (Eq, Ord)+instance Storable GTimeVal where+ sizeOf _ = {# sizeof GTimeVal #}+ alignment _ = alignment (undefined :: CString)+ peek ptr =+ do sec <- {# get GTimeVal->tv_sec #} ptr+ uSec <- {# get GTimeVal->tv_usec #} ptr+ return $ GTimeVal sec uSec+ poke ptr (GTimeVal sec uSec) =+ do {# set GTimeVal->tv_sec #} ptr sec+ {# set GTimeVal->tv_usec #} ptr uSec++gGetCurrentTime :: IO GTimeVal+gGetCurrentTime =+ alloca $ \ptr ->+ do {# call g_get_current_time #} $ castPtr ptr+ peek ptr++gUSleep :: GTimeValPart+ -> IO ()+gUSleep microseconds =+ {# call g_usleep #} $ fromIntegral microseconds++gTimeValAdd :: GTimeVal+ -> GTimeValPart+ -> GTimeVal+gTimeValAdd time microseconds =+ unsafePerformIO $ with time $ \ptr ->+ do {# call g_time_val_add #} (castPtr ptr) microseconds+ peek ptr++#if GLIB_CHECK_VERSION(2,12,0)+gTimeValFromISO8601 :: String+ -> Maybe GTimeVal+gTimeValFromISO8601 isoDate =+ unsafePerformIO $ withUTFString isoDate $ \cISODate ->+ alloca $ \ptr ->+ do success <- liftM toBool $ {# call g_time_val_from_iso8601 #} cISODate $ castPtr ptr+ if success+ then liftM Just $ peek ptr+ else return Nothing++gTimeValToISO8601 :: GTimeVal+ -> String+gTimeValToISO8601 time =+ unsafePerformIO $ with time $ \ptr ->+ {# call g_time_val_to_iso8601 #} (castPtr ptr) >>= readUTFString+#endif++newtype GDateDay = GDateDay {# type GDateDay #}+ deriving (Eq, Ord)+instance Bounded GDateDay where+ minBound = GDateDay 1+ maxBound = GDateDay 31++{# enum GDateMonth {underscoreToCase} deriving (Eq, Ord) #}+instance Bounded GDateMonth where+ minBound = GDateJanuary+ maxBound = GDateDecember++newtype GDateYear = GDateYear {# type GDateYear #}+ deriving (Eq, Ord)+instance Bounded GDateYear where+ minBound = GDateYear 1+ maxBound = GDateYear (maxBound :: {# type guint16 #})++type GDateJulianDay = {# type guint32 #}+newtype GDate = GDate { gDateJulianDay :: GDateJulianDay }+ deriving (Eq)+instance Storable GDate where+ sizeOf _ = {# sizeof GDate #}+ alignment _ = alignment (undefined :: CString)+ peek =+ (liftM (GDate . fromIntegral)) . {# call g_date_get_julian #} . castPtr+ poke ptr val =+ {# call g_date_set_julian #} (castPtr ptr) $ gDateJulianDay val++{# enum GDateWeekday {underscoreToCase} deriving (Eq, Ord) #}+instance Bounded GDateWeekday where+ minBound = GDateMonday+ maxBound = GDateSunday++gDateValidJulian :: GDateJulianDay+ -> Bool+gDateValidJulian =+ toBool . {# call fun g_date_valid_julian #}++gDateValidDMY :: GDateDay+ -> GDateMonth+ -> GDateYear+ -> Bool+gDateValidDMY (GDateDay day) month (GDateYear year) =+ toBool $ {# call fun g_date_valid_dmy #} day+ (fromIntegral $ fromEnum month)+ year++gDateNewJulian :: GDateJulianDay+ -> Maybe GDate+gDateNewJulian julian =+ if gDateValidJulian julian+ then Just $ GDate julian+ else Nothing++gDateNewDMY :: GDateDay+ -> GDateMonth+ -> GDateYear+ -> Maybe GDate+gDateNewDMY day month year =+ if gDateValidDMY day month year+ then Just $ unsafePerformIO $ alloca $ \ptr ->+ do let GDateDay day' = day+ GDateYear year' = year+ {# call g_date_set_dmy #} (castPtr ptr)+ day'+ (fromIntegral $ fromEnum month)+ year'+ peek ptr+ else Nothing++gDateSetDay :: GDate+ -> GDateDay+ -> Maybe GDate+gDateSetDay date (GDateDay day) =+ unsafePerformIO $ with date $ \ptr ->+ do {# call g_date_set_day #} (castPtr ptr) day+ valid <- liftM toBool $ {# call g_date_valid #} $ castPtr ptr+ if valid+ then liftM Just $ peek ptr+ else return Nothing++gDateSetMonth :: GDate+ -> GDateMonth+ -> Maybe GDate+gDateSetMonth date month =+ unsafePerformIO $ with date $ \ptr ->+ do {# call g_date_set_month #} (castPtr ptr) $ fromIntegral $ fromEnum month+ valid <- liftM toBool $ {# call g_date_valid #} $ castPtr ptr+ if valid+ then liftM Just $ peek ptr+ else return Nothing++gDateSetYear :: GDate+ -> GDateYear+ -> Maybe GDate+gDateSetYear date (GDateYear year) =+ unsafePerformIO $ with date $ \ptr ->+ do {# call g_date_set_year #} (castPtr ptr) year+ valid <- liftM toBool $ {# call g_date_valid #} $ castPtr ptr+ if valid+ then liftM Just $ peek ptr+ else return Nothing++#if GLIB_CHECK_VERSION(2,10,0)+gDateNewTimeVal :: GTimeVal+ -> GDate+gDateNewTimeVal timeVal =+ unsafePerformIO $ alloca $ \ptr ->+ with timeVal $ \timeValPtr ->+ do {# call g_date_set_time_val #} (castPtr ptr) $ castPtr timeValPtr+ peek ptr+#endif++gDateParse :: String+ -> IO (Maybe GDate)+gDateParse str =+ alloca $ \ptr ->+ do withUTFString str $ {# call g_date_set_parse #} $ castPtr ptr+ valid <- liftM toBool $ {# call g_date_valid #} $ castPtr ptr+ if valid+ then liftM Just $ peek ptr+ else return Nothing++gDateAddDays :: GDate+ -> Word+ -> GDate+gDateAddDays date nDays =+ unsafePerformIO $ with date $ \ptr ->+ do {# call g_date_add_days #} (castPtr ptr) $ fromIntegral nDays+ peek ptr++gDateSubtractDays :: GDate+ -> Word+ -> GDate+gDateSubtractDays date nDays =+ unsafePerformIO $ with date $ \ptr ->+ do {# call g_date_subtract_days #} (castPtr ptr) $ fromIntegral nDays+ peek ptr++gDateAddMonths :: GDate+ -> Word+ -> GDate+gDateAddMonths date nMonths =+ unsafePerformIO $ with date $ \ptr ->+ do {# call g_date_add_months #} (castPtr ptr) $ fromIntegral nMonths+ peek ptr++gDateSubtractMonths :: GDate+ -> Word+ -> GDate+gDateSubtractMonths date nMonths =+ unsafePerformIO $ with date $ \ptr ->+ do {# call g_date_subtract_months #} (castPtr ptr) $ fromIntegral nMonths+ peek ptr++gDateAddYears :: GDate+ -> Word+ -> GDate+gDateAddYears date nYears =+ unsafePerformIO $ with date $ \ptr ->+ do {# call g_date_add_years #} (castPtr ptr) $ fromIntegral nYears+ peek ptr++gDateSubtractYears :: GDate+ -> Word+ -> GDate+gDateSubtractYears date nYears =+ unsafePerformIO $ with date $ \ptr ->+ do {# call g_date_subtract_years #} (castPtr ptr) $ fromIntegral nYears+ peek ptr++gDateDaysBetween :: GDate+ -> GDate+ -> Int+gDateDaysBetween date1 date2 =+ fromIntegral $ unsafePerformIO $ with date1 $ \ptr1 ->+ with date2 $ \ptr2 ->+ {# call g_date_days_between #} (castPtr ptr1) $ castPtr ptr2++gDateCompare :: GDate+ -> GDate+ -> Ordering+gDateCompare date1 date2 =+ let result = fromIntegral $ unsafePerformIO $ with date1 $ \ptr1 ->+ with date2 $ \ptr2 ->+ {# call g_date_compare #} (castPtr ptr1) $ castPtr ptr2+ ordering | result < 0 = LT+ | result > 0 = GT+ | otherwise = EQ+ in ordering++instance Ord GDate where+ compare = gDateCompare++gDateClamp :: GDate+ -> GDate+ -> GDate+ -> GDate+gDateClamp date minDate maxDate =+ unsafePerformIO $ with date $ \ptr ->+ with minDate $ \minPtr ->+ with maxDate $ \maxPtr ->+ do {# call g_date_clamp #} (castPtr ptr) (castPtr minPtr) $ castPtr maxPtr+ peek ptr++gDateDay :: GDate+ -> GDateDay+gDateDay date =+ GDateDay $ unsafePerformIO $ with date $ {# call g_date_get_day #} . castPtr++gDateMonth :: GDate+ -> GDateMonth+gDateMonth date =+ toEnum $ fromIntegral $ unsafePerformIO $ with date $ {# call g_date_get_month #} . castPtr++gDateYear :: GDate+ -> GDateYear+gDateYear date =+ GDateYear $ unsafePerformIO $ with date $ {# call g_date_get_year #} . castPtr++gDateWeekday :: GDate+ -> GDateWeekday+gDateWeekday date =+ toEnum $ fromIntegral $ unsafePerformIO $ with date $ {# call g_date_get_weekday #} . castPtr
+ System/Glib/GError.chs view
@@ -0,0 +1,264 @@+{-# LANGUAGE CPP, ScopedTypeVariables, DeriveDataTypeable #-}+-- -*-haskell-*-+-- GIMP Toolkit (GTK) GError API+--+-- Author : Duncan Coutts+--+-- Created: 2 July 2004+--+-- Copyright (C) 2004 Duncan Coutts+-- parts derived from Structs.hsc Copyright (c) 1999..2002 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.+--+-- |+-- Maintainer : gtk2hs-users@lists.sourceforge.net+-- Stability : provisional+-- Portability : portable (depends on GHC)+--+-- Error Reporting, glib's system for reporting errors.+--+-- 'GError's are used by glib to report recoverable runtime errors.+--+-- This module provides functions for checking glib\/gtk functions that report+-- 'GError's. It also provides functions for throwing and catching 'GError's as+-- Haskell exceptions.+--+module System.Glib.GError (++ -- * Data types+ --+ GError(..),+ GErrorDomain,+ GErrorCode,+ GErrorMessage,+ + -- * Catching GError exceptions+ -- | To catch GError exceptions thrown by Gtk2Hs functions use the+ -- catchGError* or handleGError* functions. They work in a similar way to+ -- the standard 'Control.Exception.catch' and 'Control.Exception.handle'+ -- functions.+ --+ -- 'catchGError' \/ 'handleGError' catches all GError exceptions, you provide+ -- a handler function that gets given the GError if an exception was thrown.+ -- This is the most general but is probably not what you want most of the+ -- time. It just gives you the raw error code rather than a Haskell+ -- enumeration of the error codes. Most of the time you will only want to+ -- catch a specific error or any error from a specific error domain. To+ -- catch just a single specific error use+ -- 'catchGErrorJust' \/ 'handleGErrorJust'. To catch any error in a+ -- particular error domain use 'catchGErrorJustDomain' \/+ -- 'handleGErrorJustDomain'+ --+ catchGError,+ catchGErrorJust,+ catchGErrorJustDomain,+ + handleGError,+ handleGErrorJust,+ handleGErrorJustDomain,+ + failOnGError,+ throwGError,++ -- * Checking for GErrors returned by glib\/gtk functions+ -- | * Note, these functions are only useful to implementors+ --+ -- If you are wrapping a new API that reports 'GError's you should probably+ -- use 'propagateGError' to convert the GError into an exception. You should+ -- also note in the documentation for the function that it throws GError+ -- exceptions and the Haskell enumeration for the expected glib GError+ -- domain(s), so that users know what exceptions they might want to catch.+ --+ -- If you think it is more appropriate to use an alternate return value (eg+ -- Either\/Maybe) then you should use 'checkGError'.++ GErrorClass(..),+ propagateGError,+ checkGError+ ) where++import Foreign+import Foreign.C+import System.Glib.UTFString+#if HAVE_NEW_CONTROL_EXCEPTION+import Control.OldException+#else+import Control.Exception+#endif++import Data.Dynamic++{# context lib="gtk" prefix ="gtk" #}++-- | A GError consists of a domain, code and a human readable message.+data GError = GError !GErrorDomain !GErrorCode !GErrorMessage+ deriving Typeable++type GQuark = {#type GQuark #}++-- | A code used to identify the \'namespace\' of the error. Within each error+-- domain all the error codes are defined in an enumeration. Each gtk\/gnome+-- module that uses GErrors has its own error domain. The rationale behind+-- using error domains is so that each module can organise its own error codes+-- without having to coordinate on a global error code list.+type GErrorDomain = GQuark++-- | A code to identify a specific error within a given 'GErrorDomain'. Most of+-- time you will not need to deal with this raw code since there is an+-- enumeration type for each error domain. Of course which enumeraton to use+-- depends on the error domain, but if you use 'catchGErrorJustDomain' or+-- 'handleGErrorJustDomain', this is worked out for you automatically.+type GErrorCode = Int++-- | A human readable error message.+type GErrorMessage = String+ +instance Storable GError where+ sizeOf _ = {#sizeof GError #}+ alignment _ = alignment (undefined:: GQuark)+ peek ptr = do+ (domain :: GQuark) <- {#get GError->domain #} ptr+ (code :: {#type gint #}) <- {#get GError->code #} ptr+ (msgPtr :: CString) <- {#get GError->message #} ptr+ msg <- peekUTFString msgPtr+ return $ GError (fromIntegral domain) (fromIntegral code) msg+ poke _ = error "GError::poke: not implemented"++-- | Each error domain's error enumeration type should be an instance of this+-- class. This class helps to hide the raw error and domain codes from the+-- user. This interface should be implemented by calling the approrpiate+-- @{error_domain}_error_quark@. It is safe to use a pure FFI call for this.+--+-- Example for 'Graphics.UI.Gtk.Gdk.Pixbuf.PixbufError':+--+-- > instance GErrorClass PixbufError where+-- > gerrorDomain _ = {#call pure unsafe pixbuf_error_quark#}+--+class Enum err => GErrorClass err where+ gerrorDomain :: err -> GErrorDomain -- ^ This must not use the value of its+ -- parameter so that it is safe to pass+ -- 'undefined'.++-- | Glib functions which report 'GError's take as a parameter a @GError+-- **error@. Use this function to supply such a parameter. It checks if an+-- error was reported and if so throws it as a Haskell exception.+--+-- Example of use:+--+-- > propagateGError $ \gerrorPtr ->+-- > {# call g_some_function_that_might_return_an_error #} a b gerrorPtr+--+propagateGError :: (Ptr (Ptr ()) -> IO a) -> IO a+propagateGError action = checkGError action throwGError++-- | Like 'propagateGError' but instead of throwing the GError as an exception+-- handles the error immediately using the supplied error handler.+--+-- Example of use:+--+-- > checkGError+-- > (\gerrorPtr -> {# call g_some_function_that_might_return_an_error #} a b gerrorPtr)+-- > (\(GError domain code msg) -> ...)+--+checkGError :: (Ptr (Ptr ()) -> IO a) -> (GError -> IO a) -> IO a+checkGError action handler =+ alloca $ \(errPtrPtr :: Ptr (Ptr GError)) -> do+ poke errPtrPtr nullPtr+ result <- action (castPtr errPtrPtr)+ errPtr <- peek errPtrPtr+ if errPtr == nullPtr+ then return result+ else do gerror <- peek errPtr+ {# call unsafe g_error_free #} (castPtr errPtr)+ handler gerror++-- | Use this if you need to explicitly throw a GError or re-throw an existing+-- GError that you do not wish to handle.+throwGError :: GError -> IO a+throwGError gerror = evaluate (throwDyn gerror)++-- | This will catch any GError exception. The handler function will receive the+-- raw GError. This is probably only useful when you want to take some action+-- that does not depend on which GError exception has occured, otherwise it+-- would be better to use either 'catchGErrorJust' or 'catchGErrorJustDomain'.+-- For example:+--+-- > catchGError+-- > (do ...+-- > ...)+-- > (\(GError dom code msg) -> fail msg)+-- +catchGError :: IO a -- ^ The computation to run+ -> (GError -> IO a) -- ^ Handler to invoke if an exception is raised+ -> IO a+catchGError action handler = catchDyn action handler++-- | This will catch just a specific GError exception. If you need to catch a+-- range of related errors, 'catchGErrorJustDomain' is probably more+-- appropriate. Example:+--+-- > do image <- catchGErrorJust PixbufErrorCorruptImage+-- > loadImage+-- > (\errorMessage -> do log errorMessage+-- > return mssingImagePlaceholder)+--+catchGErrorJust :: GErrorClass err => err -- ^ The error to catch+ -> IO a -- ^ The computation to run+ -> (GErrorMessage -> IO a) -- ^ Handler to invoke if an exception is raised+ -> IO a+catchGErrorJust code action handler = catchGError action handler'+ where handler' gerror@(GError domain code' msg)+ | fromIntegral domain == gerrorDomain code+ && code' == fromEnum code = handler msg+ | otherwise = throwGError gerror++-- | Catch all GErrors from a particular error domain. The handler function+-- should just deal with one error enumeration type. If you need to catch+-- errors from more than one error domain, use this function twice with an+-- appropriate handler functions for each.+--+-- > catchGErrorJustDomain+-- > loadImage+-- > (\err message -> case err of+-- > PixbufErrorCorruptImage -> ...+-- > PixbufErrorInsufficientMemory -> ...+-- > PixbufErrorUnknownType -> ...+-- > _ -> ...)+--+catchGErrorJustDomain :: GErrorClass err => IO a -- ^ The computation to run+ -> (err -> GErrorMessage -> IO a) -- ^ Handler to invoke if an exception is raised+ -> IO a+catchGErrorJustDomain action (handler :: err -> GErrorMessage -> IO a) =+ catchGError action handler'+ where handler' gerror@(GError domain code msg)+ | fromIntegral domain == gerrorDomain (undefined::err) = handler (toEnum code) msg+ | otherwise = throwGError gerror++-- | A verson of 'catchGError' with the arguments swapped around.+--+-- > handleGError (\(GError dom code msg) -> ...) $+-- > ...+-- +handleGError :: (GError -> IO a) -> IO a -> IO a+handleGError = flip catchGError++-- | A verson of 'handleGErrorJust' with the arguments swapped around.+handleGErrorJust :: GErrorClass err => err -> (GErrorMessage -> IO a) -> IO a -> IO a+handleGErrorJust code = flip (catchGErrorJust code)++-- | A verson of 'handleGErrorJustDomain' with the arguments swapped around.+handleGErrorJustDomain :: GErrorClass err => (err -> GErrorMessage -> IO a) -> IO a -> IO a+handleGErrorJustDomain = flip catchGErrorJustDomain++-- | Catch all GError exceptions and convert them into a general failure.+failOnGError :: IO a -> IO a+failOnGError action = catchGError action (\(GError dom code msg) -> fail msg)
+ System/Glib/GList.chs view
@@ -0,0 +1,146 @@+-- -*-haskell-*-+-- GIMP Toolkit (GTK)+--+-- Author : Axel Simon+--+-- Created: 19 March 2002+--+-- Copyright (C) 2002 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.+--+-- |+-- Maintainer : gtk2hs-users@lists.sourceforge.net+-- Stability : provisional+-- Portability : portable (depends on GHC)+--+-- Defines functions to extract data from a GList and to produce a GList from+-- a list of pointers.+--+-- * The same for GSList.+--+module System.Glib.GList (+ GList,+ readGList,+ fromGList,+ toGList,+ withGList,++ GSList,+ readGSList,+ fromGSList,+ fromGSListRev,+ toGSList,+ withGSList,+ ) where++import Foreign+import Control.Exception (bracket)++{# context lib="glib" prefix="g" #}++{#pointer * GList#}+{#pointer * GSList#}++-- methods++-- Turn a GList into a list of pointers but don't destroy the list.+--+readGList :: GList -> IO [Ptr a]+readGList glist+ | glist==nullPtr = return []+ | otherwise = do+ x <- {#get GList->data#} glist+ glist' <- {#get GList->next#} glist+ xs <- readGList glist'+ return (castPtr x:xs)++-- Turn a GList into a list of pointers (freeing the GList in the process).+--+fromGList :: GList -> IO [Ptr a]+fromGList glist = do+ glist' <- {#call unsafe list_reverse#} glist+ extractList glist' []+ where+ extractList gl xs+ | gl==nullPtr = return xs+ | otherwise = do+ x <- {#get GList.data#} gl+ gl' <- {#call unsafe list_delete_link#} gl gl+ extractList gl' (castPtr x:xs)++-- Turn a GSList into a list of pointers but don't destroy the list.+--+readGSList :: GSList -> IO [Ptr a]+readGSList gslist+ | gslist==nullPtr = return []+ | otherwise = do+ x <- {#get GSList->data#} gslist+ gslist' <- {#get GSList->next#} gslist+ xs <- readGSList gslist'+ return (castPtr x:xs)++-- Turn a GSList into a list of pointers (freeing the GSList in the process).+--+fromGSList :: GSList -> IO [Ptr a]+fromGSList gslist+ | gslist==nullPtr = return []+ | otherwise = do+ x <- {#get GSList->data#} gslist+ gslist' <- {#call unsafe slist_delete_link#} gslist gslist+ xs <- fromGSList gslist'+ return (castPtr x:xs)++-- Turn a GSList into a list of pointers and reverse it.+--+fromGSListRev :: GSList -> IO [Ptr a]+fromGSListRev gslist =+ extractList gslist []+ where+ extractList gslist xs+ | gslist==nullPtr = return xs+ | otherwise = do+ x <- {#get GSList->data#} gslist+ gslist' <- {#call unsafe slist_delete_link#} gslist gslist+ extractList gslist' (castPtr x:xs)++-- Turn a list of something into a GList.+--+toGList :: [Ptr a] -> IO GList+toGList xs = makeList nullPtr xs+ where+ -- makeList :: GList -> [Ptr a] -> IO GList+ makeList current (x:xs) = do+ newHead <- {#call unsafe list_prepend#} current (castPtr x)+ makeList newHead xs+ makeList current [] = return current++-- Turn a list of something into a GSList.+--+toGSList :: [Ptr a] -> IO GSList+toGSList xs = makeList nullPtr xs+ where+ -- makeList :: GSList -> [Ptr a] -> IO GSList+ makeList current (x:xs) = do+ newHead <- {#call unsafe slist_prepend#} current (castPtr x)+ makeList newHead xs+ makeList current [] = return current++-- Temporarily allocate a list of something+--+withGList :: [Ptr a] -> (GSList -> IO b) -> IO b+withGList xs = bracket (toGList xs) {# call unsafe g_list_free #}++-- Temporarily allocate a list of something+--+withGSList :: [Ptr a] -> (GSList -> IO b) -> IO b+withGSList xs = bracket (toGSList xs) {# call unsafe g_slist_free #}+
+ System/Glib/GObject.chs view
@@ -0,0 +1,209 @@+{-# LANGUAGE CPP #-}+-- -*-haskell-*-+-- GIMP Toolkit (GTK) GObject+--+-- Author : Axel Simon+--+-- Created: 9 April 2001+--+-- Copyright (C) 2001 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.+--+-- |+-- Maintainer : gtk2hs-users@lists.sourceforge.net+-- Stability : provisional+-- Portability : portable (depends on GHC)+--+-- The base object type for all glib objects+--+module System.Glib.GObject (+ -- * Types+ module System.Glib.Types,++ -- * Low level binding functions++ -- | All these functions are internal and are only interesting to people+ -- writing bindings to GObject-style C libraries.+ objectNew,+ objectRef,+#if GLIB_CHECK_VERSION(2,10,0)+ objectRefSink,+#endif+ makeNewGObject,+ constructNewGObject,+ + -- ** GType queries+ gTypeGObject,+ isA,++ -- ** Callback support+ DestroyNotify,+ destroyFunPtr,+ destroyStablePtr,++ -- ** User-Defined Attributes+ Quark,+ quarkFromString,+ objectCreateAttribute,+ objectSetAttribute,+ objectGetAttributeUnsafe+ ) where++import Control.Monad (liftM, when)+import Data.IORef (newIORef, readIORef, writeIORef)++import System.Glib.FFI+import System.Glib.UTFString+{#import System.Glib.Types#}+import System.Glib.GValue (GValue)+import System.Glib.GType (GType, typeInstanceIsA)+import System.Glib.GParameter+import System.Glib.Attributes (newNamedAttr, Attr)+import Foreign.StablePtr+import Control.Concurrent.MVar ( MVar, newMVar, modifyMVar )++{# context lib="glib" prefix="g" #}++{# pointer *GParameter as GParm -> GParameter #}++-- | Construct a new object (should rairly be used directly)+--+objectNew :: GType -> [(String, GValue)] -> IO (Ptr GObject)+objectNew objType parameters =+ liftM castPtr $ --caller must makeNewGObject as we don't know+ --if it this a GObject or a GtkObject+ withArray (map GParameter parameters) $ \paramArrayPtr ->+ {# call g_object_newv #} objType+ (fromIntegral $ length parameters) paramArrayPtr++#if GLIB_CHECK_VERSION(2,10,0)+-- | Reference and sink an object.+objectRefSink :: GObjectClass obj => Ptr obj -> IO ()+objectRefSink obj = do+ {#call unsafe object_ref_sink#} (castPtr obj)+ return ()+#endif++-- | Increase the reference counter of an object+--+objectRef :: GObjectClass obj => Ptr obj -> IO ()+objectRef obj = do+ {#call unsafe object_ref#} (castPtr obj)+ return ()++-- | The type constant to check if an instance is of 'GObject' type.+gTypeGObject :: GType+gTypeGObject =+ {# call fun unsafe g_object_get_type #}++-- | This function wraps any object that does not derive from Object.+-- It should be used whenever a function returns a pointer to an existing+-- 'GObject' (as opposed to a function that constructs a new object).+--+-- * The first argument is the contructor of the specific object.+--+makeNewGObject ::+ GObjectClass obj+ => (ForeignPtr obj -> obj, FinalizerPtr obj)+ -- ^ constructor for the Haskell object and finalizer C function+ -> IO (Ptr obj) -- ^ action which yields a pointer to the C object+ -> IO obj+makeNewGObject (constr, objectUnref) generator = do+ objPtr <- generator+ when (objPtr == nullPtr) (fail "makeNewGObject: object is NULL")+ objectRef objPtr+ obj <- newForeignPtr objPtr objectUnref+ return $! constr obj++{#pointer GDestroyNotify as DestroyNotify#}++foreign import ccall "wrapper" mkDestroyNotifyPtr :: IO () -> IO DestroyNotify++-- | This function wraps any object that does not+-- derive from Object. The object is NOT reference, hence it should be used+-- when a new object is created. Newly created 'GObject's have a reference+-- count of one, hence don't need ref'ing.+--+constructNewGObject :: GObjectClass obj => + (ForeignPtr obj -> obj, FinalizerPtr obj) -> IO (Ptr obj) -> IO obj+constructNewGObject (constr, objectUnref) generator = do+ objPtr <- generator+#if GLIB_CHECK_VERSION(2,10,0)+ -- change the exisiting floating reference into a proper reference;+ -- the name is confusing, what the function does is ref,sink,unref+ objectRefSink objPtr+#endif+ obj <- newForeignPtr objPtr objectUnref+ return $! constr obj++-- | Many methods in classes derived from GObject take a callback function and+-- a destructor function which is called to free that callback function when+-- it is no longer required. This constants is an address of a functions in+-- C land that will free a function pointer.+foreign import ccall unsafe "&freeHaskellFunctionPtr" destroyFunPtr :: DestroyNotify++type Quark = {#type GQuark#}++-- | A counter for generating unique names.+{-# NOINLINE uniqueCnt #-}+uniqueCnt :: MVar Int+uniqueCnt = unsafePerformIO $ newMVar 0++-- | Create a unique id based on the given string.+quarkFromString :: String -> IO Quark+quarkFromString name = withUTFString name {#call unsafe quark_from_string#}++-- | Add an attribute to this object.+--+-- * The function returns a new attribute that can be set or retrieved from+-- any 'GObject'. The attribute is wrapped in a 'Maybe' type to reflect+-- the circumstance when the attribute is not set or if it should be unset.+--+objectCreateAttribute :: GObjectClass o => IO (Attr o (Maybe a))+objectCreateAttribute = do+ cnt <- modifyMVar uniqueCnt (\cnt -> return (cnt+1, cnt))+ let propName = "Gtk2HsAttr"++show cnt+ attr <- quarkFromString propName+ return (newNamedAttr propName (objectGetAttributeUnsafe attr)+ (objectSetAttribute attr)) ++-- | The address of a function freeing a 'StablePtr'. See 'destroyFunPtr'.+foreign import ccall unsafe "&hs_free_stable_ptr" destroyStablePtr :: DestroyNotify++-- | Set the value of an association.+--+objectSetAttribute :: GObjectClass o => Quark -> o -> Maybe a -> IO ()+objectSetAttribute attr obj Nothing = do+ {#call object_set_qdata#} (toGObject obj) attr nullPtr+objectSetAttribute attr obj (Just val) = do+ sPtr <- newStablePtr val+ {#call object_set_qdata_full#} (toGObject obj) attr (castStablePtrToPtr sPtr)+ destroyStablePtr++-- | Get the value of an association.+--+-- * Note that this function may crash the Haskell run-time since the+-- returned type can be forced to be anything. See 'objectCreateAttribute'+-- for a safe wrapper around this funciton.+--+objectGetAttributeUnsafe :: GObjectClass o => Quark -> o -> IO (Maybe a)+objectGetAttributeUnsafe attr obj = do+ sPtr <- {#call unsafe object_get_qdata#} (toGObject obj) attr+ if sPtr==nullPtr then return Nothing else+ liftM Just $! deRefStablePtr (castPtrToStablePtr sPtr)++-- | Determine if this is an instance of a particular GTK type+--+isA :: GObjectClass o => o -> GType -> Bool+isA obj gType = + typeInstanceIsA ((unsafeForeignPtrToPtr.castForeignPtr.unGObject.toGObject) obj) gType+
+ System/Glib/GParameter.hsc view
@@ -0,0 +1,49 @@+-- -*-haskell-*-+-- GIMP Toolkit (GTK) GParameter+--+-- Author : Duncan Coutts+--+-- Created: 29 March 2004+--+-- Copyright (c) 2004 Duncan Coutts+-- +-- 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.+--+-- |+-- Maintainer : gtk2hs-users@lists.sourceforge.net+-- Stability : provisional+-- Portability : portable (depends on GHC)+--+-- Storable instance for GParameter, used by objectNew+--++module System.Glib.GParameter (+ GParameter(..)+ ) where++import Foreign+import Foreign.C++import System.Glib.GValue++#include<glib-object.h>++--newtype GParameter = GParameter (String, GenericValue)+newtype GParameter = GParameter (String, GValue)++instance Storable GParameter where+ sizeOf _ = #const sizeof(GParameter)+ alignment _ = #{const __alignof__(GParameter)}+ poke ptr (GParameter (name, GValue gvaluePtr)) = do+ strPtr <- newCString name+ #{poke GParameter, name} ptr strPtr+-- poke (#{ptr GParameter, value} ptr) value+ #{poke GParameter, value} ptr gvaluePtr
+ System/Glib/GType.chs view
@@ -0,0 +1,47 @@+-- -*-haskell-*-+-- GIMP Toolkit (GTK) GType+--+-- Author : Axel Simon+--+-- Created: 1 June 2001+--+-- Copyright (c) 1999..2002 Axel Simon+--+-- Copyright (C) 2001 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.+--+-- |+-- Maintainer : gtk2hs-users@lists.sourceforge.net+-- Stability : provisional+-- Portability : portable (depends on GHC)+--+-- This module implements only the necessities for the GTK binding.+--+module System.Glib.GType (+ GType,+ typeInstanceIsA+ ) where++import System.Glib.FFI++{# context lib="glib" prefix="g" #}++type GType = {#type GType#}++-- | Check if an object is of the specific type or derived from it.+--+-- * Internally used by Hierarchy.+--+typeInstanceIsA :: Ptr () -> GType -> Bool+typeInstanceIsA obj p = toBool $+ unsafePerformIO ({#call unsafe g_type_check_instance_is_a#} obj p)+
+ System/Glib/GTypeConstants.hsc view
@@ -0,0 +1,63 @@+-- -*-haskell-*-+-- GIMP Toolkit (GTK) GType constants+--+-- Author : Axel Simon+--+-- Created: 23 May 2001+--+-- Copyright (c) 1999..2002 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.+--+-- |+-- Maintainer : gtk2hs-users@lists.sourceforge.net+-- Stability : provisional+-- Portability : portable (depends on GHC)+--+module System.Glib.GTypeConstants (+ invalid,+ none,+ uint, int,+ uint64, int64,+ uchar, char,+ bool,+ enum, flags,+ pointer,+ float, double,+ string,+ object,+ boxed+ ) where++import System.Glib.GType (GType)++#include<glib-object.h>++invalid, none, uint, int, uint64, int64, uchar, char, bool, enum, flags,+ pointer, float, double, string, object, boxed :: GType++invalid = #const G_TYPE_INVALID+none = #const G_TYPE_NONE+uint = #const G_TYPE_UINT+int = #const G_TYPE_INT+uint64 = #const G_TYPE_UINT64+int64 = #const G_TYPE_INT64+uchar = #const G_TYPE_UCHAR+char = #const G_TYPE_CHAR+bool = #const G_TYPE_BOOLEAN+enum = #const G_TYPE_ENUM+flags = #const G_TYPE_FLAGS+pointer = #const G_TYPE_POINTER+float = #const G_TYPE_FLOAT+double = #const G_TYPE_DOUBLE+string = #const G_TYPE_STRING+object = #const G_TYPE_OBJECT+boxed = #const G_TYPE_BOXED
+ System/Glib/GValue.chs view
@@ -0,0 +1,68 @@+-- -*-haskell-*-+-- GIMP Toolkit (GTK) GValue+--+-- Author : Axel Simon+--+-- Created: 1 June 2001+--+-- Copyright (c) 1999..2002 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.+--+-- |+-- Maintainer : gtk2hs-users@lists.sourceforge.net+-- Stability : provisional+-- Portability : portable (depends on GHC)+--+-- This module implements only the necessities for the GTK binding.+--+-- * Everything here is only used by "Graphics.UI.Gtk.TreeList.TreeModel" and+-- friends.+--+module System.Glib.GValue (+ GValue(GValue),+ valueInit,+ valueGetType,+ allocaGValue+ ) where++import System.Glib.FFI+import System.Glib.GType (GType)++{# context lib="glib" prefix="g" #}++{# pointer *GValue newtype #}++-- | Clear a GValue.+--+valueInit :: GValue -> GType -> IO ()+valueInit gv gt = do+ -- The g_type field of the value must be zero or g_value_init will fail.+ {# call unsafe value_init #} gv gt+ return ()++-- | Get the type of the value stored in the GValue+--+valueGetType :: GValue -> IO GType+valueGetType (GValue gvPtr) = {# get GValue->g_type #} gvPtr++-- | Temporarily allocate a GValue.+--+allocaGValue :: (GValue -> IO b) -> IO b+allocaGValue body =+ -- c2hs is broken in that it can't handle arrays of compound arrays in the+ -- sizeof hook+ allocaBytes ({# sizeof GType #}+ 2* {# sizeof guint64 #}) $ \gvPtr -> do+ -- The g_type field of the value must be zero or g_value_init will fail.+ {# set GValue->g_type #} gvPtr (0 :: GType)+ result <- body (GValue gvPtr)+ {#call unsafe value_unset#} (GValue gvPtr)+ return result
+ System/Glib/GValueTypes.chs view
@@ -0,0 +1,225 @@+-- -*-haskell-*-+-- GIMP Toolkit (GTK) GValueTypes+--+-- Author : Axel Simon+--+-- Created: 1 June 2001+--+-- Copyright (c) 1999..2002 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.+--+-- |+-- Maintainer : gtk2hs-users@lists.sourceforge.net+-- Stability : provisional+-- Portability : portable (depends on GHC)+--+-- This is used by the implementation of properties and by the+-- 'Graphics.UI.Gtk.TreeList.TreeModel' and+-- related modules.+--+module System.Glib.GValueTypes (+ valueSetUInt,+ valueGetUInt,+ valueSetInt,+ valueGetInt,+ valueSetUInt64,+ valueGetUInt64,+ valueSetInt64,+ valueGetInt64,+ valueSetBool,+ valueGetBool,+ valueSetPointer,+ valueGetPointer,+ valueSetFloat,+ valueGetFloat,+ valueSetDouble,+ valueGetDouble,+ valueSetEnum,+ valueGetEnum,+ valueSetFlags,+ valueGetFlags,+ valueSetString,+ valueGetString,+ valueSetMaybeString,+ valueGetMaybeString,+ valueSetBoxed,+ valueGetBoxed,+ valueSetGObject,+ valueGetGObject,+ valueSetMaybeGObject,+ valueGetMaybeGObject,+ ) where++import Control.Monad (liftM)++import System.Glib.FFI+import System.Glib.Flags+import System.Glib.UTFString+{#import System.Glib.GValue#} (GValue(GValue))+import System.Glib.GObject++{# context lib="glib" prefix="g" #}++valueSetUInt :: GValue -> Word -> IO ()+valueSetUInt gvalue value =+ {# call unsafe value_set_uint #} gvalue (fromIntegral value)++valueGetUInt :: GValue -> IO Word+valueGetUInt gvalue =+ liftM fromIntegral $+ {# call unsafe value_get_uint #} gvalue++valueSetInt :: GValue -> Int -> IO ()+valueSetInt gvalue value =+ {# call unsafe value_set_int #} gvalue (fromIntegral value)++valueGetInt :: GValue -> IO Int+valueGetInt gvalue =+ liftM fromIntegral $+ {# call unsafe value_get_int #} gvalue++valueSetUInt64 :: GValue -> Word64 -> IO ()+valueSetUInt64 gvalue value =+ {# call unsafe value_set_uint64 #} gvalue (fromIntegral value)++valueGetUInt64 :: GValue -> IO Word64+valueGetUInt64 gvalue =+ liftM fromIntegral $+ {# call unsafe value_get_uint64 #} gvalue++valueSetInt64 :: GValue -> Int64 -> IO ()+valueSetInt64 gvalue value =+ {# call unsafe value_set_int64 #} gvalue (fromIntegral value)++valueGetInt64 :: GValue -> IO Int64+valueGetInt64 gvalue =+ liftM fromIntegral $+ {# call unsafe value_get_int64 #} gvalue++valueSetBool :: GValue -> Bool -> IO ()+valueSetBool gvalue value =+ {# call unsafe value_set_boolean #} gvalue (fromBool value)++valueGetBool :: GValue -> IO Bool+valueGetBool gvalue =+ liftM toBool $+ {# call unsafe value_get_boolean #} gvalue++-- These functions should probably never be used as they are dangerous.+--+valueSetPointer :: GValue -> (Ptr ()) -> IO ()+valueSetPointer gvalue value =+ {# call unsafe value_set_pointer #} gvalue value++valueGetPointer :: GValue -> IO (Ptr ())+valueGetPointer gvalue =+ {# call unsafe value_get_pointer #} gvalue++valueSetFloat :: GValue -> Float -> IO ()+valueSetFloat gvalue value =+ {# call unsafe value_set_float #} gvalue (realToFrac value)++valueGetFloat :: GValue -> IO Float+valueGetFloat gvalue =+ liftM realToFrac $+ {# call unsafe value_get_float #} gvalue++valueSetDouble :: GValue -> Double -> IO ()+valueSetDouble gvalue value =+ {# call unsafe value_set_double #} gvalue (realToFrac value)++valueGetDouble :: GValue -> IO Double+valueGetDouble gvalue =+ liftM realToFrac $+ {# call unsafe value_get_double #} gvalue++valueSetEnum :: Enum enum => GValue -> enum -> IO ()+valueSetEnum gvalue value =+ {# call unsafe value_set_enum #} gvalue (fromIntegral $ fromEnum value)++valueGetEnum :: Enum enum => GValue -> IO enum+valueGetEnum gvalue =+ liftM (toEnum . fromIntegral) $+ {# call unsafe value_get_enum #} gvalue++valueSetFlags :: Flags flag => GValue -> [flag] -> IO ()+valueSetFlags gvalue value =+ {# call unsafe value_set_flags #} gvalue (fromIntegral $ fromFlags value)++valueGetFlags :: Flags flag => GValue -> IO [flag]+valueGetFlags gvalue =+ liftM (toFlags . fromIntegral) $+ {# call unsafe value_get_flags #} gvalue++valueSetString :: GValue -> String -> IO ()+valueSetString gvalue str =+ withUTFString str $ \strPtr ->+ {# call unsafe value_set_string #} gvalue strPtr++valueGetString :: GValue -> IO String+valueGetString gvalue = do+ strPtr <- {# call unsafe value_get_string #} gvalue+ if strPtr == nullPtr+ then return ""+ else peekUTFString strPtr++valueSetMaybeString :: GValue -> Maybe String -> IO ()+valueSetMaybeString gvalue (Just str) =+ withUTFString str $ \strPtr ->+ {# call unsafe value_set_string #} gvalue strPtr++valueSetMaybeString gvalue Nothing =+ {# call unsafe value_set_static_string #} gvalue nullPtr++valueGetMaybeString :: GValue -> IO (Maybe String)+valueGetMaybeString gvalue =+ {# call unsafe value_get_string #} gvalue+ >>= maybePeek peekUTFString++valueSetBoxed :: (boxed -> (Ptr boxed -> IO ()) -> IO ()) -> GValue -> boxed -> IO ()+valueSetBoxed with gvalue boxed =+ with boxed $ \boxedPtr -> do+ {# call unsafe g_value_set_boxed #} gvalue (castPtr boxedPtr)++valueGetBoxed :: (Ptr boxed -> IO boxed) -> GValue -> IO boxed+valueGetBoxed peek gvalue =+ {# call unsafe g_value_get_boxed #} gvalue >>= peek . castPtr++-- for some weird reason the API says that gv is a gpointer, not a GObject+--+valueSetGObject :: GObjectClass gobj => GValue -> gobj -> IO ()+valueSetGObject gvalue obj =+ withForeignPtr ((unGObject.toGObject) obj) $ \objPtr ->+ {# call unsafe g_value_set_object #} gvalue (castPtr objPtr)++-- Unsafe because it performs an unchecked downcast. Only for internal use.+--+valueGetGObject :: GObjectClass gobj => GValue -> IO gobj+valueGetGObject gvalue =+ liftM unsafeCastGObject $+ makeNewGObject mkGObject $+ throwIfNull "GValue.valueGetObject: extracting invalid object" $+ liftM castPtr $+ {# call unsafe value_get_object #} gvalue++valueSetMaybeGObject :: GObjectClass gobj => GValue -> (Maybe gobj) -> IO ()+valueSetMaybeGObject gvalue (Just obj) = valueSetGObject gvalue obj+valueSetMaybeGObject gvalue Nothing =+ {# call unsafe g_value_set_object #} gvalue nullPtr++valueGetMaybeGObject :: GObjectClass gobj => GValue -> IO (Maybe gobj)+valueGetMaybeGObject gvalue =+ liftM (liftM unsafeCastGObject) $+ maybeNull (makeNewGObject mkGObject) $+ liftM castPtr $+ {# call unsafe value_get_object #} gvalue+
+ System/Glib/MainLoop.chs view
@@ -0,0 +1,348 @@+{-# LANGUAGE CPP #-}+-- -*-haskell-*-+-- GIMP Toolkit (GTK) General+--+-- Author : Axel Simon, Manuel M. T. Chakravarty, Duncan Coutts+--+-- Created: 11 October 2005+--+-- Copyright (C) 2000..2005 Axel Simon, Manuel M. T. Chakravarty, Duncan Coutts+--+-- 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.+--+-- |+-- Maintainer : gtk2hs-users@lists.sourceforge.net+-- Stability : provisional+-- Portability : portable (depends on GHC)+--+-- main event loop, and events+--+module System.Glib.MainLoop (+ HandlerId,+ timeoutAdd,+ timeoutAddFull,+ timeoutRemove,+ idleAdd,+ idleRemove,+ IOCondition(..),+ inputAdd,+ inputRemove,+ Priority,+ priorityLow,+ priorityDefaultIdle,+ priorityHighIdle,+ priorityDefault,+ priorityHigh,+ MainLoop,+ mainLoopNew,+ mainLoopRun,+ mainLoopQuit,+ mainLoopIsRunning,+ MainContext,+ mainContextNew,+ mainContextDefault,+ mainContextIteration,+ mainContextFindSourceById,+ Source(..),+ sourceAttach,+ sourceSetPriority,+ sourceGetPriority,+ sourceDestroy,+#if GLIB_CHECK_VERSION(2,12,0)+ sourceIsDestroyed+#endif+ ) where++import Control.Monad (liftM)++import System.Glib.FFI+import System.Glib.Flags+import System.Glib.GObject (DestroyNotify, destroyFunPtr)++{#context lib="glib" prefix ="g"#}++{#pointer SourceFunc#}++foreign import ccall "wrapper" mkSourceFunc :: IO {#type gint#} -> IO SourceFunc++type HandlerId = {#type guint#}++-- Turn a function into a function pointer and a destructor pointer.+--+makeCallback :: IO {#type gint#} -> IO (SourceFunc, DestroyNotify)+makeCallback fun = do+ funPtr <- mkSourceFunc fun+ return (funPtr, destroyFunPtr)++-- | Sets a function to be called at regular intervals, with the default+-- priority 'priorityDefault'. The function is called repeatedly until it+-- returns @False@, after which point the timeout function will not be called+-- again. The first call to the function will be at the end of the first interval.+--+-- Note that timeout functions may be delayed, due to the processing of other+-- event sources. Thus they should not be relied on for precise timing. After+-- each call to the timeout function, the time of the next timeout is+-- recalculated based on the current time and the given interval (it does not+-- try to 'catch up' time lost in delays).+--+timeoutAdd :: IO Bool -> Int -> IO HandlerId+timeoutAdd fun msec = timeoutAddFull fun priorityDefault msec++-- | Sets a function to be called at regular intervals, with the given+-- priority. The function is called repeatedly until it returns @False@, after+-- which point the timeout function will not be called again. The first call+-- to the function will be at the end of the first interval.+--+-- Note that timeout functions may be delayed, due to the processing of other+-- event sources. Thus they should not be relied on for precise timing. After+-- each call to the timeout function, the time of the next timeout is+-- recalculated based on the current time and the given interval (it does not+-- try to 'catch up' time lost in delays).+--+timeoutAddFull :: IO Bool -> Priority -> Int -> IO HandlerId+timeoutAddFull fun pri msec = do+ (funPtr, dPtr) <- makeCallback (liftM fromBool fun)+ {#call unsafe g_timeout_add_full#}+ (fromIntegral pri)+ (fromIntegral msec)+ funPtr+ (castFunPtrToPtr funPtr)+ dPtr++-- | Remove a previously added timeout handler by its 'HandlerId'.+--+timeoutRemove :: HandlerId -> IO ()+timeoutRemove id = {#call source_remove#} id >> return ()++-- | Add a callback that is called whenever the system is idle.+--+-- * A priority can be specified via an integer. This should usually be+-- 'priorityDefaultIdle'.+--+-- * If the function returns @False@ it will be removed.+--+idleAdd :: IO Bool -> Priority -> IO HandlerId+idleAdd fun pri = do+ (funPtr, dPtr) <- makeCallback (liftM fromBool fun)+ {#call unsafe idle_add_full#} (fromIntegral pri) funPtr+ (castFunPtrToPtr funPtr) dPtr++-- | Remove a previously added idle handler by its 'HandlerId'.+--+idleRemove :: HandlerId -> IO ()+idleRemove id = {#call source_remove#} id >> return ()++-- | Flags representing a condition to watch for on a file descriptor.+--+-- [@IOIn@] There is data to read.+-- [@IOOut@] Data can be written (without blocking).+-- [@IOPri@] There is urgent data to read.+-- [@IOErr@] Error condition.+-- [@IOHup@] Hung up (the connection has been broken, usually for+-- pipes and sockets).+-- [@IOInvalid@] Invalid request. The file descriptor is not open.+--+{# enum IOCondition {+ G_IO_IN as IOIn,+ G_IO_OUT as IOOut,+ G_IO_PRI as IOPri,+ G_IO_ERR as IOErr,+ G_IO_HUP as IOHup,+ G_IO_NVAL as IOInvalid+ } deriving (Eq, Bounded) #}+instance Flags IOCondition++{#pointer *IOChannel newtype#}+{#pointer IOFunc#}++foreign import ccall "wrapper" mkIOFunc :: (Ptr IOChannel -> CInt -> Ptr () -> IO {#type gboolean#}) -> IO IOFunc++type FD = Int++-- | Adds the file descriptor into the main event loop with the given priority.+--+inputAdd ::+ FD -- ^ a file descriptor+ -> [IOCondition] -- ^ the condition to watch for+ -> Priority -- ^ the priority of the event source+ -> IO Bool -- ^ the function to call when the condition is satisfied.+ -- The function should return False if the event source+ -- should be removed.+ -> IO HandlerId -- ^ the event source id+inputAdd fd conds pri fun = do+ funPtr <- mkIOFunc (\_ _ _ -> liftM fromBool fun)+ channel <- {#call unsafe g_io_channel_unix_new #} (fromIntegral fd)+ {#call unsafe g_io_add_watch_full#}+ (IOChannel channel)+ (fromIntegral pri)+ ((fromIntegral . fromFlags) conds)+ funPtr+ (castFunPtrToPtr funPtr)+ destroyFunPtr++inputRemove :: HandlerId -> IO ()+inputRemove id = {#call source_remove#} id >> return ()++-- Standard priorities++#define G_PRIORITY_HIGH -100+#define G_PRIORITY_DEFAULT 0+#define G_PRIORITY_HIGH_IDLE 100+#define G_PRIORITY_DEFAULT_IDLE 200+#define G_PRIORITY_LOW 300++-- | Priorities for installing callbacks.+--+type Priority = Int++priorityHigh :: Int+priorityHigh = G_PRIORITY_HIGH++priorityDefault :: Int+priorityDefault = G_PRIORITY_DEFAULT++priorityHighIdle :: Int+priorityHighIdle = G_PRIORITY_HIGH_IDLE++priorityDefaultIdle :: Int+priorityDefaultIdle = G_PRIORITY_DEFAULT_IDLE++priorityLow :: Int+priorityLow = G_PRIORITY_LOW++-- | A main event loop abstraction.+{# pointer *GMainLoop as MainLoop foreign newtype #}++-- | An opaque datatype representing a set of sources to be handled in+-- a main loop.+{# pointer *GMainContext as MainContext foreign newtype #}++-- | Create a new 'MainLoop'.+mainLoopNew :: Maybe MainContext -- ^ @context@ - the context to use, or 'Nothing' to use the default context+ -> Bool -- ^ @isRunning@ - 'True' to indicate that the loop is running; 'False' otherwise+ -> IO MainLoop -- ^ the new 'MainLoop'+mainLoopNew context isRunning =+ do let context' = maybe (MainContext nullForeignPtr) id context+ loopPtr <- {# call main_loop_new #} context' $ fromBool isRunning+ liftM MainLoop $ newForeignPtr loopPtr mainLoopFinalizer+foreign import ccall unsafe "&g_main_loop_unref"+ mainLoopFinalizer :: FunPtr (Ptr MainLoop -> IO ())++-- | Runs a main loop until 'mainLoopQuit' is called on the+-- loop. If this is called for the thread of the loop's+-- 'MainContext', it will process events from the loop, otherwise it+-- will simply wait.+mainLoopRun :: MainLoop+ -> IO ()+mainLoopRun loop =+ {# call main_loop_run #} loop++-- | Stops a 'MainLoop' from running. Any calls to mainLoopRun for the+-- loop will return.+mainLoopQuit :: MainLoop+ -> IO ()+mainLoopQuit loop =+ {# call main_loop_quit #} loop++-- | Checks to see if the main loop is currently being run via mainLoopRun.+mainLoopIsRunning :: MainLoop+ -> IO Bool+mainLoopIsRunning loop =+ liftM toBool $ {# call main_loop_is_running #} loop++-- | Gets a 'MainLoop's context.+mainLoopGetContext :: MainLoop+ -> MainContext+mainLoopGetContext loop =+ MainContext $ unsafePerformIO $+ {# call main_loop_get_context #} loop >>=+ flip newForeignPtr mainContextFinalizer++foreign import ccall unsafe "&g_main_context_unref"+ mainContextFinalizer :: FunPtr (Ptr MainContext -> IO ())++-- | Creates a new 'MainContext'.+mainContextNew :: IO MainContext+mainContextNew =+ newContextMarshal {# call main_context_new #}++-- | The default 'MainContext'. This is the main context used for main+-- loop functions when a main loop is not explicitly specified.+mainContextDefault :: MainContext+mainContextDefault =+ unsafePerformIO $ newContextMarshal {# call main_context_default #}++newContextMarshal action =+ do ptr <- action+ liftM MainContext $ newForeignPtr ptr mainContextFinalizer++-- | Runs a single iteration for the given main loop. This involves+-- checking to see if any event sources are ready to be processed,+-- then if no events sources are ready and @mayBlock@ is 'True',+-- waiting for a source to become ready, then dispatching the+-- highest priority events sources that are ready. Note that even+-- when @mayBlock@ is 'True', it is still possible for+-- 'mainContextIteration' to return FALSE, since the the wait+-- may be interrupted for other reasons than an event source+-- becoming ready.+mainContextIteration :: MainContext+ -> Bool+ -> IO Bool+mainContextIteration context mayBlock =+ liftM toBool $ {# call main_context_iteration #} context (fromBool mayBlock)++mainContextFindSourceById :: MainContext+ -> HandlerId+ -> IO Source+mainContextFindSourceById context id =+ {# call main_context_find_source_by_id #} context (fromIntegral id) >>= newSource . castPtr++{# pointer *GSource as Source foreign newtype #}+newSource :: Ptr Source+ -> IO Source+newSource sourcePtr =+ liftM Source $ newForeignPtr sourcePtr sourceFinalizer+foreign import ccall unsafe "&g_source_unref"+ sourceFinalizer :: FunPtr (Ptr Source -> IO ())++sourceAttach :: Source+ -> MainContext+ -> IO HandlerId+sourceAttach source context =+ liftM fromIntegral $ {# call source_attach #} source context++sourceSetPriority :: Source+ -> Priority+ -> IO ()+sourceSetPriority source priority =+ {# call source_set_priority #} source $ fromIntegral priority++sourceGetPriority :: Source+ -> IO Priority+sourceGetPriority source =+ liftM fromIntegral $ {# call source_get_priority #} source++sourceDestroy :: Source+ -> IO ()+sourceDestroy source =+ {# call source_destroy #} source++#if GLIB_CHECK_VERSION(2,12,0)+sourceIsDestroyed :: Source+ -> IO Bool+sourceIsDestroyed source =+ liftM toBool $ {# call source_is_destroyed #} source+#endif++sourceRemove :: HandlerId+ -> IO Bool+sourceRemove tag =+ liftM toBool $ {# call source_remove #} $ fromIntegral tag
+ System/Glib/Properties.chs view
@@ -0,0 +1,347 @@+-- -*-haskell-*-+-- GIMP Toolkit (GTK) GObject Properties+--+-- Author : Duncan Coutts+--+-- Created: 16 April 2005+--+-- Copyright (C) 2005 Duncan Coutts+--+-- 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.+--+-- |+-- Maintainer : gtk2hs-users@lists.sourceforge.net+-- Stability : provisional+-- Portability : portable (depends on GHC)+--+-- Functions for getting and setting GObject properties+--+module System.Glib.Properties (+ -- * per-type functions for getting and setting GObject properties+ objectSetPropertyInt,+ objectGetPropertyInt,+ objectSetPropertyUInt,+ objectGetPropertyUInt,+ objectSetPropertyInt64,+ objectGetPropertyInt64,+ objectSetPropertyUInt64,+ objectGetPropertyUInt64,+ objectSetPropertyChar,+ objectGetPropertyChar,+ objectSetPropertyBool,+ objectGetPropertyBool,+ objectSetPropertyEnum,+ objectGetPropertyEnum,+ objectSetPropertyFlags,+ objectGetPropertyFlags,+ objectSetPropertyFloat,+ objectGetPropertyFloat,+ objectSetPropertyDouble,+ objectGetPropertyDouble,+ objectSetPropertyString,+ objectGetPropertyString,+ objectSetPropertyMaybeString,+ objectGetPropertyMaybeString, + objectSetPropertyBoxedOpaque,+ objectGetPropertyBoxedOpaque,+ objectSetPropertyBoxedStorable,+ objectGetPropertyBoxedStorable,+ objectSetPropertyGObject,+ objectGetPropertyGObject,++ -- * constructors for attributes backed by GObject properties+ newAttrFromIntProperty,+ readAttrFromIntProperty,+ newAttrFromUIntProperty,+ newAttrFromCharProperty,+ writeAttrFromUIntProperty,+ newAttrFromBoolProperty,+ readAttrFromBoolProperty,+ newAttrFromFloatProperty,+ newAttrFromDoubleProperty,+ newAttrFromEnumProperty,+ readAttrFromEnumProperty,+ writeAttrFromEnumProperty,+ newAttrFromFlagsProperty,+ newAttrFromStringProperty,+ readAttrFromStringProperty,+ writeAttrFromStringProperty,+ newAttrFromMaybeStringProperty,+ readAttrFromMaybeStringProperty,+ writeAttrFromMaybeStringProperty,+ newAttrFromBoxedOpaqueProperty,+ readAttrFromBoxedOpaqueProperty,+ writeAttrFromBoxedOpaqueProperty,+ newAttrFromBoxedStorableProperty,+ newAttrFromObjectProperty,+ writeAttrFromObjectProperty,+ readAttrFromObjectProperty,+ newAttrFromMaybeObjectProperty,+ writeAttrFromMaybeObjectProperty,+ readAttrFromMaybeObjectProperty,+ + -- TODO: do not export these once we dump the old TreeList API:+ objectGetPropertyInternal,+ objectSetPropertyInternal,+ ) where++import Control.Monad (liftM)++import System.Glib.FFI+import System.Glib.Flags (Flags)+{#import System.Glib.Types#}+{#import System.Glib.GValue#} (GValue(GValue), valueInit, allocaGValue)+import qualified System.Glib.GTypeConstants as GType+import System.Glib.GType+import System.Glib.GValueTypes+import System.Glib.Attributes (Attr, ReadAttr, WriteAttr, ReadWriteAttr,+ newNamedAttr, readNamedAttr, writeNamedAttr)++{# context lib="glib" prefix="g" #}++objectSetPropertyInternal :: GObjectClass gobj => GType -> (GValue -> a -> IO ()) -> String -> gobj -> a -> IO ()+objectSetPropertyInternal gtype valueSet prop obj val =+ withCString prop $ \propPtr ->+ allocaGValue $ \gvalue -> do+ valueInit gvalue gtype+ valueSet gvalue val+ {# call g_object_set_property #}+ (toGObject obj)+ propPtr+ gvalue++objectGetPropertyInternal :: GObjectClass gobj => GType -> (GValue -> IO a) -> String -> gobj -> IO a+objectGetPropertyInternal gtype valueGet prop obj =+ withCString prop $ \propPtr ->+ allocaGValue $ \gvalue -> do+ valueInit gvalue gtype+ {# call unsafe g_object_get_property #}+ (toGObject obj)+ propPtr+ gvalue+ valueGet gvalue++objectSetPropertyInt :: GObjectClass gobj => String -> gobj -> Int -> IO ()+objectSetPropertyInt = objectSetPropertyInternal GType.int valueSetInt++objectGetPropertyInt :: GObjectClass gobj => String -> gobj -> IO Int+objectGetPropertyInt = objectGetPropertyInternal GType.int valueGetInt++objectSetPropertyUInt :: GObjectClass gobj => String -> gobj -> Int -> IO ()+objectSetPropertyUInt = objectSetPropertyInternal GType.uint (\gv v -> valueSetUInt gv (fromIntegral v))++objectGetPropertyUInt :: GObjectClass gobj => String -> gobj -> IO Int+objectGetPropertyUInt = objectGetPropertyInternal GType.uint (\gv -> liftM fromIntegral $ valueGetUInt gv)++objectSetPropertyInt64 :: GObjectClass gobj => String -> gobj -> Int64 -> IO ()+objectSetPropertyInt64 = objectSetPropertyInternal GType.int64 valueSetInt64++objectGetPropertyInt64 :: GObjectClass gobj => String -> gobj -> IO Int64+objectGetPropertyInt64 = objectGetPropertyInternal GType.int64 valueGetInt64++objectSetPropertyUInt64 :: GObjectClass gobj => String -> gobj -> Word64 -> IO ()+objectSetPropertyUInt64 = objectSetPropertyInternal GType.uint64 (\gv v -> valueSetUInt64 gv (fromIntegral v))++objectGetPropertyUInt64 :: GObjectClass gobj => String -> gobj -> IO Word64+objectGetPropertyUInt64 = objectGetPropertyInternal GType.uint64 (\gv -> liftM fromIntegral $ valueGetUInt64 gv)++objectSetPropertyChar :: GObjectClass gobj => String -> gobj -> Char -> IO ()+objectSetPropertyChar = objectSetPropertyInternal GType.uint (\gv v -> valueSetUInt gv (fromIntegral (fromEnum v)))++objectGetPropertyChar :: GObjectClass gobj => String -> gobj -> IO Char+objectGetPropertyChar = objectGetPropertyInternal GType.uint (\gv -> liftM (toEnum . fromIntegral) $ valueGetUInt gv)++objectSetPropertyBool :: GObjectClass gobj => String -> gobj -> Bool -> IO ()+objectSetPropertyBool = objectSetPropertyInternal GType.bool valueSetBool++objectGetPropertyBool :: GObjectClass gobj => String -> gobj -> IO Bool+objectGetPropertyBool = objectGetPropertyInternal GType.bool valueGetBool++objectSetPropertyEnum :: (GObjectClass gobj, Enum enum) => GType -> String -> gobj -> enum -> IO ()+objectSetPropertyEnum gtype = objectSetPropertyInternal gtype valueSetEnum++objectGetPropertyEnum :: (GObjectClass gobj, Enum enum) => GType -> String -> gobj -> IO enum+objectGetPropertyEnum gtype = objectGetPropertyInternal gtype valueGetEnum++objectSetPropertyFlags :: (GObjectClass gobj, Flags flag) => GType -> String -> gobj -> [flag] -> IO ()+objectSetPropertyFlags gtype = objectSetPropertyInternal gtype valueSetFlags++objectGetPropertyFlags :: (GObjectClass gobj, Flags flag) => GType -> String -> gobj -> IO [flag]+objectGetPropertyFlags gtype = objectGetPropertyInternal gtype valueGetFlags++objectSetPropertyFloat :: GObjectClass gobj => String -> gobj -> Float -> IO ()+objectSetPropertyFloat = objectSetPropertyInternal GType.float valueSetFloat++objectGetPropertyFloat :: GObjectClass gobj => String -> gobj -> IO Float+objectGetPropertyFloat = objectGetPropertyInternal GType.float valueGetFloat++objectSetPropertyDouble :: GObjectClass gobj => String -> gobj -> Double -> IO ()+objectSetPropertyDouble = objectSetPropertyInternal GType.double valueSetDouble++objectGetPropertyDouble :: GObjectClass gobj => String -> gobj -> IO Double+objectGetPropertyDouble = objectGetPropertyInternal GType.double valueGetDouble++objectSetPropertyString :: GObjectClass gobj => String -> gobj -> String -> IO ()+objectSetPropertyString = objectSetPropertyInternal GType.string valueSetString++objectGetPropertyString :: GObjectClass gobj => String -> gobj -> IO String+objectGetPropertyString = objectGetPropertyInternal GType.string valueGetString++objectSetPropertyMaybeString :: GObjectClass gobj => String -> gobj -> Maybe String -> IO ()+objectSetPropertyMaybeString = objectSetPropertyInternal GType.string valueSetMaybeString++objectGetPropertyMaybeString :: GObjectClass gobj => String -> gobj -> IO (Maybe String)+objectGetPropertyMaybeString = objectGetPropertyInternal GType.string valueGetMaybeString++objectSetPropertyBoxedOpaque :: GObjectClass gobj => (boxed -> (Ptr boxed -> IO ()) -> IO ()) -> GType -> String -> gobj -> boxed -> IO ()+objectSetPropertyBoxedOpaque with gtype = objectSetPropertyInternal gtype (valueSetBoxed with)++objectGetPropertyBoxedOpaque :: GObjectClass gobj => (Ptr boxed -> IO boxed) -> GType -> String -> gobj -> IO boxed+objectGetPropertyBoxedOpaque peek gtype = objectGetPropertyInternal gtype (valueGetBoxed peek)++objectSetPropertyBoxedStorable :: (GObjectClass gobj, Storable boxed) => GType -> String -> gobj -> boxed -> IO ()+objectSetPropertyBoxedStorable = objectSetPropertyBoxedOpaque with++objectGetPropertyBoxedStorable :: (GObjectClass gobj, Storable boxed) => GType -> String -> gobj -> IO boxed+objectGetPropertyBoxedStorable = objectGetPropertyBoxedOpaque peek++objectSetPropertyGObject :: (GObjectClass gobj, GObjectClass gobj') => GType -> String -> gobj -> gobj' -> IO ()+objectSetPropertyGObject gtype = objectSetPropertyInternal gtype valueSetGObject++objectGetPropertyGObject :: (GObjectClass gobj, GObjectClass gobj') => GType -> String -> gobj -> IO gobj'+objectGetPropertyGObject gtype = objectGetPropertyInternal gtype valueGetGObject++objectSetPropertyMaybeGObject :: (GObjectClass gobj, GObjectClass gobj') => GType -> String -> gobj -> (Maybe gobj') -> IO ()+objectSetPropertyMaybeGObject gtype = objectSetPropertyInternal gtype valueSetMaybeGObject++objectGetPropertyMaybeGObject :: (GObjectClass gobj, GObjectClass gobj') => GType -> String -> gobj -> IO (Maybe gobj')+objectGetPropertyMaybeGObject gtype = objectGetPropertyInternal gtype valueGetMaybeGObject+++-- Convenience functions to make attribute implementations in the other modules+-- shorter and more easily extensible.+--++newAttrFromIntProperty :: GObjectClass gobj => String -> Attr gobj Int+newAttrFromIntProperty propName =+ newNamedAttr propName (objectGetPropertyInt propName) (objectSetPropertyInt propName)++readAttrFromIntProperty :: GObjectClass gobj => String -> ReadAttr gobj Int+readAttrFromIntProperty propName =+ readNamedAttr propName (objectGetPropertyInt propName)++newAttrFromUIntProperty :: GObjectClass gobj => String -> Attr gobj Int+newAttrFromUIntProperty propName =+ newNamedAttr propName (objectGetPropertyUInt propName) (objectSetPropertyUInt propName)++newAttrFromCharProperty :: GObjectClass gobj => String -> Attr gobj Char+newAttrFromCharProperty propName =+ newNamedAttr propName (objectGetPropertyChar propName) (objectSetPropertyChar propName)++writeAttrFromUIntProperty :: GObjectClass gobj => String -> WriteAttr gobj Int+writeAttrFromUIntProperty propName =+ writeNamedAttr propName (objectSetPropertyUInt propName)++newAttrFromBoolProperty :: GObjectClass gobj => String -> Attr gobj Bool+newAttrFromBoolProperty propName =+ newNamedAttr propName (objectGetPropertyBool propName) (objectSetPropertyBool propName)++readAttrFromBoolProperty :: GObjectClass gobj => String -> ReadAttr gobj Bool+readAttrFromBoolProperty propName =+ readNamedAttr propName (objectGetPropertyBool propName)++newAttrFromFloatProperty :: GObjectClass gobj => String -> Attr gobj Float+newAttrFromFloatProperty propName =+ newNamedAttr propName (objectGetPropertyFloat propName) (objectSetPropertyFloat propName)++newAttrFromDoubleProperty :: GObjectClass gobj => String -> Attr gobj Double+newAttrFromDoubleProperty propName =+ newNamedAttr propName (objectGetPropertyDouble propName) (objectSetPropertyDouble propName)++newAttrFromEnumProperty :: (GObjectClass gobj, Enum enum) => String -> GType -> Attr gobj enum+newAttrFromEnumProperty propName gtype =+ newNamedAttr propName (objectGetPropertyEnum gtype propName) (objectSetPropertyEnum gtype propName)++readAttrFromEnumProperty :: (GObjectClass gobj, Enum enum) => String -> GType -> ReadAttr gobj enum+readAttrFromEnumProperty propName gtype =+ readNamedAttr propName (objectGetPropertyEnum gtype propName)++writeAttrFromEnumProperty :: (GObjectClass gobj, Enum enum) => String -> GType -> WriteAttr gobj enum+writeAttrFromEnumProperty propName gtype =+ writeNamedAttr propName (objectSetPropertyEnum gtype propName)++newAttrFromFlagsProperty :: (GObjectClass gobj, Flags flag) => String -> GType -> Attr gobj [flag]+newAttrFromFlagsProperty propName gtype =+ newNamedAttr propName (objectGetPropertyFlags gtype propName) (objectSetPropertyFlags gtype propName)++newAttrFromStringProperty :: GObjectClass gobj => String -> Attr gobj String+newAttrFromStringProperty propName =+ newNamedAttr propName (objectGetPropertyString propName) (objectSetPropertyString propName)++readAttrFromStringProperty :: GObjectClass gobj => String -> ReadAttr gobj String+readAttrFromStringProperty propName =+ readNamedAttr propName (objectGetPropertyString propName)++writeAttrFromStringProperty :: GObjectClass gobj => String -> WriteAttr gobj String+writeAttrFromStringProperty propName =+ writeNamedAttr propName (objectSetPropertyString propName)++newAttrFromMaybeStringProperty :: GObjectClass gobj => String -> Attr gobj (Maybe String)+newAttrFromMaybeStringProperty propName =+ newNamedAttr propName (objectGetPropertyMaybeString propName) (objectSetPropertyMaybeString propName)++readAttrFromMaybeStringProperty :: GObjectClass gobj => String -> ReadAttr gobj (Maybe String)+readAttrFromMaybeStringProperty propName =+ readNamedAttr propName (objectGetPropertyMaybeString propName)++writeAttrFromMaybeStringProperty :: GObjectClass gobj => String -> WriteAttr gobj (Maybe String)+writeAttrFromMaybeStringProperty propName =+ writeNamedAttr propName (objectSetPropertyMaybeString propName)++newAttrFromBoxedOpaqueProperty :: GObjectClass gobj => (Ptr boxed -> IO boxed) -> (boxed -> (Ptr boxed -> IO ()) -> IO ()) -> String -> GType -> Attr gobj boxed+newAttrFromBoxedOpaqueProperty peek with propName gtype =+ newNamedAttr propName (objectGetPropertyBoxedOpaque peek gtype propName) (objectSetPropertyBoxedOpaque with gtype propName)++readAttrFromBoxedOpaqueProperty :: GObjectClass gobj => (Ptr boxed -> IO boxed) -> String -> GType -> ReadAttr gobj boxed+readAttrFromBoxedOpaqueProperty peek propName gtype =+ readNamedAttr propName (objectGetPropertyBoxedOpaque peek gtype propName)++writeAttrFromBoxedOpaqueProperty :: GObjectClass gobj => (boxed -> (Ptr boxed -> IO ()) -> IO ()) -> String -> GType -> WriteAttr gobj boxed+writeAttrFromBoxedOpaqueProperty with propName gtype =+ writeNamedAttr propName (objectSetPropertyBoxedOpaque with gtype propName)++newAttrFromBoxedStorableProperty :: (GObjectClass gobj, Storable boxed) => String -> GType -> Attr gobj boxed+newAttrFromBoxedStorableProperty propName gtype =+ newNamedAttr propName (objectGetPropertyBoxedStorable gtype propName) (objectSetPropertyBoxedStorable gtype propName)++newAttrFromObjectProperty :: (GObjectClass gobj, GObjectClass gobj', GObjectClass gobj'') => String -> GType -> ReadWriteAttr gobj gobj' gobj''+newAttrFromObjectProperty propName gtype =+ newNamedAttr propName (objectGetPropertyGObject gtype propName) (objectSetPropertyGObject gtype propName)++writeAttrFromObjectProperty :: (GObjectClass gobj, GObjectClass gobj') => String -> GType -> WriteAttr gobj gobj'+writeAttrFromObjectProperty propName gtype =+ writeNamedAttr propName (objectSetPropertyGObject gtype propName)++readAttrFromObjectProperty :: (GObjectClass gobj, GObjectClass gobj') => String -> GType -> ReadAttr gobj gobj'+readAttrFromObjectProperty propName gtype =+ readNamedAttr propName (objectGetPropertyGObject gtype propName)++newAttrFromMaybeObjectProperty :: (GObjectClass gobj, GObjectClass gobj', GObjectClass gobj'') => String -> GType -> ReadWriteAttr gobj (Maybe gobj') (Maybe gobj'')+newAttrFromMaybeObjectProperty propName gtype =+ newNamedAttr propName (objectGetPropertyMaybeGObject gtype propName) (objectSetPropertyMaybeGObject gtype propName)+ +writeAttrFromMaybeObjectProperty :: (GObjectClass gobj, GObjectClass gobj') => String -> GType -> WriteAttr gobj (Maybe gobj')+writeAttrFromMaybeObjectProperty propName gtype =+ writeNamedAttr propName (objectSetPropertyMaybeGObject gtype propName)++readAttrFromMaybeObjectProperty :: (GObjectClass gobj, GObjectClass gobj') => String -> GType -> ReadAttr gobj (Maybe gobj')+readAttrFromMaybeObjectProperty propName gtype =+ readNamedAttr propName (objectGetPropertyMaybeGObject gtype propName)
+ System/Glib/Signals.chs view
@@ -0,0 +1,213 @@+{-# LANGUAGE CPP #-}+{-# CFILES hsgclosure.c #-}+-- -*-haskell-*-+-- Callback installers for the GIMP Toolkit (GTK) Binding for Haskell+--+-- Author : Axel Simon+--+-- Created: 1 July 2000+--+-- Copyright (C) 2000-2005 Axel Simon, Duncan Coutts+--+-- 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.+--+-- #prune++-- 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 possiblity 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.Glib.Signals (+ Signal(Signal),+ on, after,+ SignalName,+ ConnectAfter,+ ConnectId(ConnectId),+ signalDisconnect,+ signalBlock,+ signalUnblock,+ signalStopEmission,+ disconnect,+ GClosure,+#ifdef USE_GCLOSURE_SIGNALS_IMPL+ connectGeneric,+#else+ GClosureNotify,+ mkFunPtrClosureNotify,+#endif+ ) where++import System.Glib.FFI+{#import System.Glib.GObject#}+#ifndef USE_GCLOSURE_SIGNALS_IMPL+import Data.IORef+#endif++{#context lib="glib" prefix="g" #}++newtype Signal object handler =+ Signal (Bool -> object -> handler -> IO (ConnectId object))++-- | Perform an action in response to a signal.+--+-- Use it like this:+--+-- > on obj sig $ do+-- > ...+--+-- or if the signal handler takes any arguments:+--+-- > on obj sig $ \args -> do+-- > ...+--+on ::+ object+ -> Signal object callback+ -> callback+ -> IO (ConnectId object)+on object (Signal connect) handler = connect False object handler++-- | Perform an action in response to a signal.+--+-- * Like 'on' but the signal is executed after Gtk's default handler has+-- run.+--+after ::+ object+ -> Signal object callback+ -> callback+ -> IO (ConnectId object)+after object (Signal connect) handler = connect True object handler++-- Specify if the handler is to run before (False) or after (True) the+-- default handler.++type ConnectAfter = Bool++type SignalName = String++-- | The type of signal handler ids. If you ever need to 'disconnect' a signal+-- handler then you will need to retain the 'ConnectId' you got when you+-- registered it.+--+data GObjectClass o => ConnectId o = ConnectId {#type gulong#} o++-- old name for backwards compatability+disconnect :: GObjectClass obj => ConnectId obj -> IO ()+disconnect = signalDisconnect+{-# DEPRECATED disconnect "use signalDisconnect instead" #-}++-- | Disconnect a signal handler. After disconnecting the handler will no+-- longer be invoked when the event occurs.+--+signalDisconnect :: GObjectClass obj => ConnectId obj -> IO ()+signalDisconnect (ConnectId handler obj) =+ withForeignPtr ((unGObject.toGObject) obj) $ \objPtr ->+ {# call g_signal_handler_disconnect #} (castPtr objPtr) handler++-- | Block a specific signal handler.+--+-- * Blocks a handler of an instance so it will not be called during any+-- signal emissions unless it is unblocked again. Thus \"blocking\" a signal+-- handler means to temporarily deactive it, a signal handler has to be+-- unblocked exactly the same amount of times it has been blocked before+-- to become active again.+--+signalBlock :: GObjectClass obj => ConnectId obj -> IO ()+signalBlock (ConnectId handler obj) =+ withForeignPtr ((unGObject.toGObject) obj) $ \objPtr ->+ {# call g_signal_handler_block #} (castPtr objPtr) handler+ +-- | Unblock a specific signal handler.+--+-- * Undoes the effect of a previous 'signalBlock' call. A blocked handler+-- is skipped during signal emissions and will not be invoked, unblocking+-- it (for exactly the amount of times it has been blocked before) reverts+-- its \"blocked\" state, so the handler will be recognized by the signal+-- system and is called upon future or currently ongoing signal emissions+-- (since the order in which handlers are called during signal emissions+-- is deterministic, whether the unblocked handler in question is called+-- as part of a currently ongoing emission depends on how far that+-- emission has proceeded yet).+--+signalUnblock :: GObjectClass obj => ConnectId obj -> IO ()+signalUnblock (ConnectId handler obj) =+ withForeignPtr ((unGObject.toGObject) obj) $ \objPtr ->+ {# call g_signal_handler_unblock #} (castPtr objPtr) handler++-- | Stops a signal's current emission.+--+-- * This will prevent the default method from running. The sequence in which+-- handlers are run is \"first\", \"on\", \"last\" then \"after\" where+-- Gtk-internal+-- signals are connected either at \"first\" or at \"last\". Hence this+-- function can only stop the signal processing if it is called from within+-- a handler that is connected with an \"on\" signal and if the Gtk-internal+-- handler is connected as \"last\". Gtk prints a warning if this function+-- is used on a signal which isn't being emitted.+--+signalStopEmission :: GObjectClass obj => obj -> SignalName -> IO ()+signalStopEmission obj sigName =+ withForeignPtr ((unGObject.toGObject) obj) $ \objPtr ->+ withCString sigName $ \strPtr ->+ {# call g_signal_stop_emission_by_name #} (castPtr objPtr) strPtr++{# pointer *GClosure newtype #}++#ifdef USE_GCLOSURE_SIGNALS_IMPL++connectGeneric :: GObjectClass obj =>+ SignalName+ -> ConnectAfter+ -> obj+ -> handler+ -> IO (ConnectId obj)+connectGeneric signal after obj user = do+ sptr <- newStablePtr user+ gclosurePtr <- gtk2hs_closure_new sptr+ sigId <- + withCString signal $ \signalPtr -> + withForeignPtr ((unGObject.toGObject) obj) $ \objPtr ->+ {# call g_signal_connect_closure #}+ (castPtr objPtr)+ signalPtr+ (GClosure gclosurePtr)+ (fromBool after)+ return $ ConnectId sigId obj++foreign import ccall unsafe "gtk2hs_closure_new"+ gtk2hs_closure_new :: StablePtr a -> IO (Ptr GClosure)++#else++{#pointer GClosureNotify#}++foreign import ccall "wrapper" mkDestructor :: IO () -> IO GClosureNotify + +mkFunPtrClosureNotify :: FunPtr a -> IO GClosureNotify+mkFunPtrClosureNotify hPtr = do + dRef <- newIORef nullFunPtr + dPtr <- mkDestructor $ do + freeHaskellFunPtr hPtr + dPtr <- readIORef dRef + freeHaskellFunPtr dPtr + writeIORef dRef dPtr + return dPtr++#endif
+ System/Glib/StoreValue.hsc view
@@ -0,0 +1,161 @@+-- -*-haskell-*-+-- GIMP Toolkit (GTK) StoreValue GenericValue+--+-- Author : Axel Simon+--+-- Created: 23 May 2001+--+-- Copyright (c) 1999..2002 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.+--+-- TODO: this module is deprecated and should be removed. The GenericValue+-- type is currently exposed to users and it should not be.+--+-- |+-- Maintainer : gtk2hs-users@lists.sourceforge.net+-- Stability : provisional+-- Portability : portable (depends on GHC)+--+module System.Glib.StoreValue (+ TMType(..),+ GenericValue(..),+ valueSetGenericValue,+ valueGetGenericValue,+ ) where++import Control.Monad (liftM)++#if HAVE_NEW_CONTROL_EXCEPTION+import Control.OldException+#else+import Control.Exception+ (throw, Exception(AssertionFailed))+#endif++#include<glib-object.h>++import System.Glib.FFI+import System.Glib.GValue (GValue, valueInit, valueGetType)+import System.Glib.GValueTypes+import qualified System.Glib.GTypeConstants as GType+import System.Glib.Types (GObject)++-- | A union with information about the currently stored type.+--+-- * Internally used by "Graphics.UI.Gtk.TreeList.TreeModel".+--+data GenericValue = GVuint Word+ | GVint Int+-- | GVuchar #{type guchar}+-- | GVchar #{type gchar}+ | GVboolean Bool+ | GVenum Int+ | GVflags Int+-- | GVpointer (Ptr ())+ | GVfloat Float+ | GVdouble Double+ | GVstring (Maybe String)+ | GVobject GObject+-- | GVboxed (Ptr ())++-- This is an enumeration of all GTypes that can be used in a TreeModel.+--+data TMType = TMinvalid+ | TMuint+ | TMint+-- | TMuchar+-- | TMchar+ | TMboolean+ | TMenum+ | TMflags+-- | TMpointer+ | TMfloat+ | TMdouble+ | TMstring+ | TMobject+-- | TMboxed++instance Enum TMType where+ fromEnum TMinvalid = #const G_TYPE_INVALID+ fromEnum TMuint = #const G_TYPE_UINT+ fromEnum TMint = #const G_TYPE_INT+-- fromEnum TMuchar = #const G_TYPE_UCHAR+-- fromEnum TMchar = #const G_TYPE_CHAR+ fromEnum TMboolean = #const G_TYPE_BOOLEAN+ fromEnum TMenum = #const G_TYPE_ENUM+ fromEnum TMflags = #const G_TYPE_FLAGS+-- fromEnum TMpointer = #const G_TYPE_POINTER+ fromEnum TMfloat = #const G_TYPE_FLOAT+ fromEnum TMdouble = #const G_TYPE_DOUBLE+ fromEnum TMstring = #const G_TYPE_STRING+ fromEnum TMobject = #const G_TYPE_OBJECT+-- fromEnum TMboxed = #const G_TYPE_BOXED+ toEnum #{const G_TYPE_INVALID} = TMinvalid+ toEnum #{const G_TYPE_UINT} = TMuint + toEnum #{const G_TYPE_INT} = TMint +-- toEnum #{const G_TYPE_UCHAR} = TMuchar +-- toEnum #{const G_TYPE_CHAR} = TMchar + toEnum #{const G_TYPE_BOOLEAN} = TMboolean + toEnum #{const G_TYPE_ENUM} = TMenum+ toEnum #{const G_TYPE_FLAGS} = TMflags+-- toEnum #{const G_TYPE_POINTER} = TMpointer + toEnum #{const G_TYPE_FLOAT} = TMfloat + toEnum #{const G_TYPE_DOUBLE} = TMdouble + toEnum #{const G_TYPE_STRING} = TMstring + toEnum #{const G_TYPE_OBJECT} = TMobject +-- toEnum #{const G_TYPE_BOXED} = TMboxed+ toEnum _ = + error "StoreValue.toEnum(TMType): no dynamic types allowed."++valueSetGenericValue :: GValue -> GenericValue -> IO ()+valueSetGenericValue gvalue (GVuint x) = do valueInit gvalue GType.uint+ valueSetUInt gvalue x+valueSetGenericValue gvalue (GVint x) = do valueInit gvalue GType.int+ valueSetInt gvalue x+--valueSetGenericValue gvalue (GVuchar x) = valueSetUChar gvalue x+--valueSetGenericValue gvalue (GVchar x) = valueSetChar gvalue x+valueSetGenericValue gvalue (GVboolean x) = do valueInit gvalue GType.bool+ valueSetBool gvalue x+valueSetGenericValue gvalue (GVenum x) = do valueInit gvalue GType.enum+ valueSetUInt gvalue (fromIntegral x)+valueSetGenericValue gvalue (GVflags x) = do valueInit gvalue GType.flags+ valueSetUInt gvalue (fromIntegral x)+--valueSetGenericValue gvalue (GVpointer x) = valueSetPointer gvalue x+valueSetGenericValue gvalue (GVfloat x) = do valueInit gvalue GType.float+ valueSetFloat gvalue x+valueSetGenericValue gvalue (GVdouble x) = do valueInit gvalue GType.double+ valueSetDouble gvalue x+valueSetGenericValue gvalue (GVstring x) = do valueInit gvalue GType.string+ valueSetMaybeString gvalue x+valueSetGenericValue gvalue (GVobject x) = do valueInit gvalue GType.object+ valueSetGObject gvalue x+--valueSetGenericValue gvalue (GVboxed x) = valueSetPointer gvalue x++valueGetGenericValue :: GValue -> IO GenericValue+valueGetGenericValue gvalue = do+ gtype <- valueGetType gvalue+ case (toEnum . fromIntegral) gtype of+ TMinvalid -> throw $ AssertionFailed + "StoreValue.valueGetGenericValue: invalid or unavailable value."+ TMuint -> liftM GVuint $ valueGetUInt gvalue+ TMint -> liftM GVint $ valueGetInt gvalue+-- TMuchar -> liftM GVuchar $ valueGetUChar gvalue+-- TMchar -> liftM GVchar $ valueGetChar gvalue+ TMboolean -> liftM GVboolean $ valueGetBool gvalue+ TMenum -> liftM (GVenum . fromIntegral) $ valueGetUInt gvalue+ TMflags -> liftM (GVflags . fromIntegral) $ valueGetUInt gvalue+-- TMpointer -> liftM GVpointer $ valueGetPointer gvalue+ TMfloat -> liftM GVfloat $ valueGetFloat gvalue+ TMdouble -> liftM GVdouble $ valueGetDouble gvalue+ TMstring -> liftM GVstring $ valueGetMaybeString gvalue+ TMobject -> liftM GVobject $ valueGetGObject gvalue+-- TMboxed -> liftM GVpointer $ valueGetPointer gvalue
+ System/Glib/Types.chs view
@@ -0,0 +1,69 @@+{-# OPTIONS_HADDOCK hide #-}+-- -*-haskell-*-+-- GIMP Toolkit (GTK) Widget GObject+--+-- Author : Axel Simon+--+-- Created: 9 April 2001+--+-- Copyright (c) 2001 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)+--+-- Implements the base GObject class.+--+module System.Glib.Types (+ GObject(..),+ GObjectClass,+ mkGObject,+ unGObject,+ toGObject,+ unsafeCastGObject,+ castToGObject,+ objectUnref+ ) where++import System.Glib.FFI++{# context lib="glib" prefix="g" #}++{#pointer *GObject foreign newtype #} deriving (Eq)++mkGObject = (GObject, objectUnref)+unGObject (GObject o) = o++class GObjectClass o where+ -- | Safe upcast.+ toGObject :: o -> GObject+ -- | Unchecked downcast.+ unsafeCastGObject :: GObject -> o+ {-# INLINE toGObject #-}+ {-# INLINE unsafeCastGObject #-}++instance GObjectClass GObject where+ toGObject = id+ unsafeCastGObject = id++castToGObject :: GObjectClass obj => obj -> obj+castToGObject = id++-- | Decrease the reference counter of an object+--+foreign import ccall unsafe "&g_object_unref"+ objectUnref :: FinalizerPtr a+
+ System/Glib/UTFString.hs view
@@ -0,0 +1,210 @@+-- GIMP Toolkit (GTK) UTF aware string marshalling+--+-- Author : Axel Simon+--+-- Created: 22 June 2001+--+-- Copyright (c) 1999..2002 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.+--+-- |+-- Maintainer : gtk2hs-users@lists.sourceforge.net+-- Stability : provisional+-- Portability : portable (depends on GHC)+--+-- This module adds CString-like functions that handle UTF8 strings.+--++module System.Glib.UTFString (+ withUTFString,+ withUTFStringLen,+ newUTFString,+ newUTFStringLen,+ peekUTFString,+ peekUTFStringLen,+ readUTFString,+ readCString,+ withUTFStrings,+ withUTFStringArray,+ withUTFStringArray0,+ peekUTFStringArray,+ peekUTFStringArray0,+ readUTFStringArray0,+ UTFCorrection,+ genUTFOfs,+ ofsToUTF,+ ofsFromUTF+ ) where++import Control.Monad (liftM)+import Data.Char (ord, chr)++import System.Glib.FFI++-- Define withUTFString to emit UTF-8.+--+withUTFString :: String -> (CString -> IO a) -> IO a+withUTFString hsStr = withCString (toUTF hsStr)++-- Define withUTFStringLen to emit UTF-8.+--+withUTFStringLen :: String -> (CStringLen -> IO a) -> IO a+withUTFStringLen hsStr = withCStringLen (toUTF hsStr)++-- Define newUTFString to emit UTF-8.+--+newUTFString :: String -> IO CString+newUTFString = newCString . toUTF++-- Define newUTFStringLen to emit UTF-8.+--+newUTFStringLen :: String -> IO CStringLen+newUTFStringLen = newCStringLen . toUTF++-- Define peekUTFString to retrieve UTF-8.+--+peekUTFString :: CString -> IO String+peekUTFString strPtr = liftM fromUTF $ peekCString strPtr++-- Define peekUTFStringLen to retrieve UTF-8.+--+peekUTFStringLen :: CStringLen -> IO String+peekUTFStringLen strPtr = liftM fromUTF $ peekCStringLen strPtr++-- like peekUTFString but then frees the string using g_free+--+readUTFString :: CString -> IO String+readUTFString strPtr = do+ str <- peekUTFString strPtr+ g_free strPtr+ return str++-- like peekCString but then frees the string using g_free+--+readCString :: CString -> IO String+readCString strPtr = do+ str <- peekCString strPtr+ g_free strPtr+ return str++foreign import ccall unsafe "g_free"+ g_free :: Ptr a -> IO ()++-- Temporarily allocate a list of UTF-8 Strings.+--+withUTFStrings :: [String] -> ([CString] -> IO a) -> IO a+withUTFStrings hsStrs = withUTFStrings' hsStrs []+ where withUTFStrings' :: [String] -> [CString] -> ([CString] -> IO a) -> IO a+ withUTFStrings' [] cs body = body (reverse cs)+ withUTFStrings' (s:ss) cs body = withUTFString s $ \c ->+ withUTFStrings' ss (c:cs) body++-- Temporarily allocate an array of UTF-8 Strings.+--+withUTFStringArray :: [String] -> (Ptr CString -> IO a) -> IO a+withUTFStringArray hsStr body =+ withUTFStrings hsStr $ \cStrs -> do+ withArray cStrs body++-- Temporarily allocate a null-terminated array of UTF-8 Strings.+--+withUTFStringArray0 :: [String] -> (Ptr CString -> IO a) -> IO a+withUTFStringArray0 hsStr body =+ withUTFStrings hsStr $ \cStrs -> do+ withArray0 nullPtr cStrs body++-- Convert an array of UTF-8 strings of the given length to a list of Haskell+-- strings.+--+peekUTFStringArray :: Int -> Ptr CString -> IO [String]+peekUTFStringArray len cStrArr = do+ cStrs <- peekArray len cStrArr+ mapM peekUTFString cStrs++-- Convert a null-terminated array of UTF-8 strings to a list of Haskell+-- strings.+--+peekUTFStringArray0 :: Ptr CString -> IO [String]+peekUTFStringArray0 cStrArr = do+ cStrs <- peekArray0 nullPtr cStrArr+ mapM peekUTFString cStrs++-- Like peekUTFStringArray0 but then free the string array using g_strfreev+readUTFStringArray0 :: Ptr CString -> IO [String]+readUTFStringArray0 cStrArr = do+ cStrs <- peekArray0 nullPtr cStrArr+ g_strfreev cStrArr+ mapM peekUTFString cStrs++foreign import ccall unsafe "g_strfreev"+ g_strfreev :: Ptr a -> IO ()++-- Convert Unicode characters to UTF-8.+--+toUTF :: String -> String+toUTF [] = []+toUTF (x:xs) | ord x<=0x007F = x:toUTF xs+ | ord x<=0x07FF = chr (0xC0 .|. ((ord x `shift` (-6)) .&. 0x1F)):+ chr (0x80 .|. (ord x .&. 0x3F)):+ toUTF xs+ | otherwise = chr (0xE0 .|. ((ord x `shift` (-12)) .&. 0x0F)):+ chr (0x80 .|. ((ord x `shift` (-6)) .&. 0x3F)):+ chr (0x80 .|. (ord x .&. 0x3F)):+ toUTF xs++-- Convert UTF-8 to Unicode.+--+fromUTF :: String -> String+fromUTF [] = []+fromUTF (all@(x:xs)) | ord x<=0x7F = x:fromUTF xs+ | ord x<=0xBF = err+ | ord x<=0xDF = twoBytes all+ | ord x<=0xEF = threeBytes all+ | otherwise = err+ where+ twoBytes (x1:x2:xs) = chr (((ord x1 .&. 0x1F) `shift` 6) .|.+ (ord x2 .&. 0x3F)):fromUTF xs+ twoBytes _ = error "fromUTF: illegal two byte sequence"++ threeBytes (x1:x2:x3:xs) = chr (((ord x1 .&. 0x0F) `shift` 12) .|.+ ((ord x2 .&. 0x3F) `shift` 6) .|.+ (ord x3 .&. 0x3F)):fromUTF xs+ threeBytes _ = error "fromUTF: illegal three byte sequence" + + err = error "fromUTF: illegal UTF-8 character"++-- Offset correction for String to UTF8 mapping.+--+newtype UTFCorrection = UTFCorrection [Int] deriving Show++-- Create a list of offset corrections.+genUTFOfs :: String -> UTFCorrection+genUTFOfs str = UTFCorrection (gUO 0 str)+ where+ gUO n [] = []+ gUO n (x:xs) | ord x<=0x007F = gUO (n+1) xs+ | ord x<=0x07FF = n:gUO (n+1) xs+ | otherwise = n:n:gUO (n+1) xs++ofsToUTF :: Int -> UTFCorrection -> Int+ofsToUTF n (UTFCorrection oc) = oTU oc+ where+ oTU [] = n+ oTU (x:xs) | n<=x = n+ | otherwise = 1+oTU xs++ofsFromUTF :: Int -> UTFCorrection -> Int+ofsFromUTF n (UTFCorrection oc) = oFU n oc+ where+ oFU n [] = n+ oFU n (x:xs) | n<=x = n+ | otherwise = oFU (n-1) xs
+ System/Glib/Utils.chs view
@@ -0,0 +1,80 @@+-- -*-haskell-*-+-- GIMP Toolkit (GTK) Miscellaneous utilities+--+-- Author : John Millikin+--+-- Created: 15 November 2009+--+-- Copyright (C) 2009 John Millikin+--+-- 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.+--+-- |+-- Maintainer : gtk2hs-users@lists.sourceforge.net+-- Stability : provisional+-- Portability : portable (depends on GHC)+--+-- This module binds GLib-specific utility procedures.+--+module System.Glib.Utils+ ( getApplicationName+ , setApplicationName+ , getProgramName+ , setProgramName+ ) where++import System.Glib.FFI+import System.Glib.UTFString++{# context lib="glib" prefix="g" #}++-- |+-- Gets a human-readable name for the application, as set by+-- 'setApplicationName'. This name should be localized if possible, and is+-- intended for display to the user. Contrast with 'getProgramName', which+-- gets a non-localized name. If 'setApplicationName' has not been performed,+-- returns the result of 'getProgramName' (which may be 'Nothing' if+-- 'setProgramName' has also not been performed).+--+getApplicationName :: IO (Maybe String)+getApplicationName = {#call unsafe get_application_name #} >>= maybePeek peekUTFString++-- |+-- Sets a human-readable name for the application. This name should be+-- localized if possible, and is intended for display to the user. Contrast+-- with 'setProgramName', which sets a non-localized name. 'setProgramName'+-- will be performed automatically by 'initGUI', but 'setApplicationName'+-- will not.+--+-- Note that for thread safety reasons, this computation can only be performed+-- once.+--+-- The application name will be used in contexts such as error messages, or+-- when displaying an application's name in the task list.+--+setApplicationName :: String -> IO ()+setApplicationName = flip withUTFString {#call unsafe set_application_name #}++-- |+-- Gets the name of the program. This name should /not/ be localized, contrast+-- with 'getApplicationName'. If you are using GDK or GTK+, the program name+-- is set in 'initGUI' to the last component of argv[0].+--+getProgramName :: IO (Maybe String)+getProgramName = {#call unsafe get_prgname #} >>= maybePeek peekUTFString++-- |+-- Sets the name of the program. This name should /not/ be localized, contrast+-- with 'setApplicationName'. Note that for thread-safety reasons this+-- computation can only be performed once.+--+setProgramName :: String -> IO ()+setProgramName = flip withUTFString {#call unsafe set_prgname #}
+ System/Glib/hsgclosure.c view
@@ -0,0 +1,281 @@+/* GIMP Toolkit (GTK) Gtk2HsClosure implementation+ *+ * Author : Duncan Coutts+ *+ * Created: 22 March 2005+ *+ * Copyright (C) 2005 Duncan Coutts+ *+ * 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.+ */++/* GHC's semi-public Rts API */+#include <Rts.h>++#include "hsgclosure.h"++#ifdef DEBUG+#define WHEN_DEBUG(a) a+#else+#define WHEN_DEBUG(a)+#endif++#if __GLASGOW_HASKELL__>604+#define GHC_RTS_USES_CAPABILITY+#define CAP cap,+#else+#define CAP+#endif++/* Gtk2HsClosure is a _private_ structure */+typedef struct _Gtk2HsClosure Gtk2HsClosure;+struct _Gtk2HsClosure {+ GClosure closure;+ HsStablePtr callback;+};++/* TODO: check if we should be using invalidate or finalise */+static void+gtk2hs_closure_invalidate(gpointer data, GClosure *closure) {+ Gtk2HsClosure *hc = (Gtk2HsClosure *)closure;+ WHEN_DEBUG(g_debug("gtk2hs_closure_invalidate: enter, callback=%p", hc->callback));++ /* I think invalidate can be called more than once in the case of cycles+ * so be safe and allow that */+ if (hc->callback)+ hs_free_stable_ptr(hc->callback);++ hc->callback = NULL;+ WHEN_DEBUG(g_debug("gtk2hs_closure_invalidate: leave"));+}++/* forward defs */+#ifdef GHC_RTS_USES_CAPABILITY+static HaskellObj gtk2hs_value_as_haskellobj(Capability *cap, const GValue *value);+#else+static HaskellObj gtk2hs_value_as_haskellobj(const GValue *value);+#endif+static void gtk2hs_value_from_haskellobj(GValue *value, HaskellObj obj);++extern StgClosure * GHCziStable_deRefStablePtr_closure;++static void+gtk2hs_closure_marshal(GClosure *closure,+ GValue *return_value,+ guint n_param_values,+ const GValue *param_values,+ gpointer invocation_hint,+ gpointer marshal_data)+{++ Gtk2HsClosure *hc = (Gtk2HsClosure *)closure;+ HaskellObj call, ret;+#ifdef GHC_RTS_USES_CAPABILITY+ Capability *cap;+#else+ SchedulerStatus cap;+#endif+ guint i;+ + WHEN_DEBUG(g_debug("gtk2hs_closure_marshal: about to run callback=%p, n_param_values=%d", hc->callback, n_param_values));+#ifdef GHC_RTS_USES_CAPABILITY+ cap = rts_lock();+#else+ rts_lock();+#endif+ + call = (StgClosure *)deRefStablePtr(hc->callback);+ + /* construct the function call */+ for (i = 0; i < n_param_values; i++) {+ WHEN_DEBUG(g_debug("gtk2hs_closure_marshal: param_values[%d]=%s :: %s",+ i,+ g_strdup_value_contents(¶m_values[i]),+ g_type_name(G_VALUE_TYPE(¶m_values[i]))));+ call = rts_apply(CAP call, gtk2hs_value_as_haskellobj(CAP ¶m_values[i]));+ }+ + WHEN_DEBUG(g_debug("gtk2hs_closure_marshal: about to rts_evalIO"));+ + /* perform the call */+ cap=rts_evalIO(CAP rts_apply(CAP (HaskellObj)runIO_closure, call),&ret);+ + WHEN_DEBUG(g_debug("gtk2hs_closure_marshal: about to rts_checkSchedStatus"));+ + /* barf if anything went wrong */+ /* TODO: pass a sensible value for call site so we get better error messages */+ /* or perhaps we can propogate any error? */+ rts_checkSchedStatus("gtk2hs_closure_marshal", cap);+ + if (return_value) {+ WHEN_DEBUG(g_debug("gtk2hs_closure_marshal: return_value :: %s",+/* g_strdup_value_contents(return_value), */+ g_type_name(G_VALUE_TYPE(return_value))));+ gtk2hs_value_from_haskellobj(return_value, ret);+ }+ +#ifdef GHC_RTS_USES_CAPABILITY+ rts_unlock(cap);+#else+ rts_unlock();+#endif+ WHEN_DEBUG(g_debug("gtk2hs_closure_marshal: done running callback"));+}++GClosure *+gtk2hs_closure_new(HsStablePtr callback)+{+ GClosure *closure;+ + WHEN_DEBUG(g_debug("gtk2hs_closure_new: enter, callback=%p", callback));+ closure = g_closure_new_simple(sizeof(Gtk2HsClosure), NULL);+ /* TODO: check if we should be using invalidate or finalise notifier */+ g_closure_add_invalidate_notifier(closure, NULL, gtk2hs_closure_invalidate);+ g_closure_set_marshal(closure, gtk2hs_closure_marshal);++ ((Gtk2HsClosure *)closure)->callback = callback;+ + WHEN_DEBUG(g_debug("gtk2hs_closure_new: leave"));+ + return closure;+}++/* GValue <-> HaskellObj marshaling functions */++static HaskellObj+#ifdef GHC_RTS_USES_CAPABILITY+gtk2hs_value_as_haskellobj(Capability *cap, const GValue *value) {+#else+gtk2hs_value_as_haskellobj(const GValue *value) {+#endif+ switch (G_TYPE_FUNDAMENTAL(G_VALUE_TYPE(value))) {+ case G_TYPE_INTERFACE:+ if (g_type_is_a(G_VALUE_TYPE(value), G_TYPE_OBJECT))+ return rts_mkPtr(CAP g_value_get_object(value));+ else+ break;+ case G_TYPE_CHAR:+ return rts_mkChar(CAP g_value_get_char(value));+ case G_TYPE_UCHAR:+ return rts_mkChar(CAP g_value_get_uchar(value));+ case G_TYPE_BOOLEAN:+ return rts_mkBool(CAP g_value_get_boolean(value));+ case G_TYPE_INT:+ return rts_mkInt(CAP g_value_get_int(value));+ case G_TYPE_UINT:+ return rts_mkWord(CAP g_value_get_uint(value));+ case G_TYPE_LONG:+ return rts_mkInt(CAP g_value_get_long(value));+ case G_TYPE_ULONG:+ return rts_mkWord(CAP g_value_get_ulong(value));+/* case G_TYPE_INT64:+ return rts_mkInt64(CAP g_value_get_int64(value));+ case G_TYPE_UINT64:+ return rts_mkWord64(CAP g_value_get_uint64(value)); */+ case G_TYPE_ENUM:+ return rts_mkInt(CAP g_value_get_enum(value));+ case G_TYPE_FLAGS:+ return rts_mkWord(CAP g_value_get_enum(value));+ case G_TYPE_FLOAT:+ return rts_mkFloat(CAP g_value_get_float(value));+ case G_TYPE_DOUBLE:+ return rts_mkDouble(CAP g_value_get_double(value));+ case G_TYPE_STRING:+ return rts_mkPtr(CAP (char *)g_value_get_string(value)); /* CHECKME: is the string freed? */+ case G_TYPE_POINTER:+ return rts_mkPtr(CAP g_value_get_pointer(value));+ case G_TYPE_BOXED:+ return rts_mkPtr(CAP g_value_get_boxed(value));+/* case G_TYPE_PARAM:+ return g_value_get_param(value); */+ case G_TYPE_OBJECT:+ return rts_mkPtr(CAP g_value_get_object(value));+ }+ g_error("gtk2hs_value_as_haskellobj: unable to handle GValue with type %s\n"+ "please report this as a bug to gtk2hs-devel@lists.sourceforge.net",+ g_type_name(G_VALUE_TYPE(value)));+}++void+gtk2hs_value_from_haskellobj(GValue *value, HaskellObj obj) {++ switch (G_TYPE_FUNDAMENTAL(G_VALUE_TYPE(value))) {+ case G_TYPE_INVALID:+ case G_TYPE_NONE:+ return;+ case G_TYPE_INTERFACE:+ /* we only handle interface types that have a GObject prereq */+ if (g_type_is_a(G_VALUE_TYPE(value), G_TYPE_OBJECT)) {+ g_value_set_object(value, rts_getPtr(obj));+ } else {+ break;+ }+ return;+ case G_TYPE_CHAR:+ g_value_set_char(value, rts_getChar(obj));+ return;+ case G_TYPE_UCHAR:+ g_value_set_char(value, rts_getChar(obj));+ return;+ case G_TYPE_BOOLEAN:+ g_value_set_boolean(value, rts_getBool(obj));+ return;+ case G_TYPE_INT:+ g_value_set_int(value, rts_getInt(obj));+ return;+ case G_TYPE_UINT:+ g_value_set_uint(value, rts_getWord(obj));+ return;+ case G_TYPE_LONG:+ g_value_set_long(value, rts_getInt(obj));+ return;+ case G_TYPE_ULONG:+ g_value_set_ulong(value, rts_getWord(obj));+ return;+/* case G_TYPE_INT64:+ g_value_set_int64(value, rts_getInt64(obj));+ return;+ case G_TYPE_UINT64:+ g_value_set_uint64(value, rts_getWord64(obj));+ return; */+ case G_TYPE_ENUM:+ g_value_set_enum(value, rts_getInt(obj));+ return;+ case G_TYPE_FLAGS:+ g_value_set_flags(value, rts_getInt(obj));+ return;+ case G_TYPE_FLOAT:+ g_value_set_float(value, rts_getFloat(obj));+ return;+ case G_TYPE_DOUBLE:+ g_value_set_double(value, rts_getDouble(obj));+ return;+ case G_TYPE_STRING:+ g_value_set_string(value, rts_getPtr(obj));+ return;+ case G_TYPE_POINTER:+ g_value_set_pointer(value, rts_getPtr(obj));+ return;+/* case G_TYPE_BOXED: {+ g_value_set_boxed(value, obj);+ break;+ }+ case G_TYPE_PARAM:+ g_value_set_param(value, (obj));+ break; */+ case G_TYPE_OBJECT:+ g_value_set_object(value, rts_getPtr(obj));+ return;+ }+ g_error("gtk2hs_value_from_haskellobj: unable to handle GValue with type %s\n"+ "please report this as a bug to gtk2hs-devel@lists.sourceforge.net",+ g_type_name(G_VALUE_TYPE(value)));+}
+ System/Glib/hsgclosure.h view
@@ -0,0 +1,22 @@+/* GIMP Toolkit (GTK) HSGClosure interface+ *+ * Author : Duncan Coutts+ *+ * Created: 22 March 2005+ *+ * Copyright (C) 2005 Duncan Coutts+ *+ * 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.+ */++#include <glib-object.h>++GClosure * gtk2hs_closure_new(HsStablePtr callback);
+ glib.cabal view
@@ -0,0 +1,67 @@+Name: glib+Version: 0.11.0+License: LGPL-2.1+License-file: COPYING+Copyright: (c) 2001-2010 The Gtk2Hs Team+Author: Axel Simon, Duncan Coutts+Maintainer: gtk2hs-users@sourceforge.net+Build-Type: Custom+Cabal-Version: >= 1.6.0+Stability: stable+homepage: http://www.haskell.org/gtk2hs/+bug-reports: http://hackage.haskell.org/trac/gtk2hs/+Synopsis: Binding to the GLIB library for Gtk2Hs.+Description: The GNU Library is a collection of C data structures and utility+ function for dealing with Unicode. This package only binds as+ much functionality as required to support the packages that+ wrap libraries that are themselves based on GLib.+Category: System+Tested-With: GHC == 6.10.4+Extra-Source-Files:+ Gtk2HsSetup.hs+ System/Glib/hsgclosure.c+ System/Glib/hsgclosure.h++Source-Repository head+ type: darcs+ location: http://code.haskell.org/gtk2hs/+ subdir: glib++Flag closure_signals+ Description: Connect to signals using the Duncan way.+++Library+ build-depends: base >= 4 && < 5,+ containers, haskell98+ build-tools: gtk2hsC2hs+ cpp-options: -DHAVE_NEW_CONTROL_EXCEPTION+ if flag(closure_signals)+ cpp-options: -DUSE_GCLOSURE_SIGNALS_IMPL+ c-sources: System/Glib/hsgclosure.c+ include-dirs: System/Glib++ exposed-modules: + System.Glib+ System.Glib.GError+ System.Glib.Properties+ System.Glib.Attributes+ System.Glib.Signals+ System.Glib.MainLoop+ System.Glib.GDateTime+ System.Glib.GObject+ System.Glib.Utils+ System.Glib.StoreValue+ System.Glib.FFI+ System.Glib.Flags+ System.Glib.UTFString+ System.Glib.Types+ System.Glib.GList+ System.Glib.GType+ System.Glib.GTypeConstants+ System.Glib.GValue+ System.Glib.GValueTypes+ System.Glib.GParameter+ extensions: ForeignFunctionInterface+ x-c2hs-Header: glib-object.h+ pkgconfig-depends: glib-2.0, gobject-2.0