diff --git a/COPYING b/COPYING new file mode 100644 --- /dev/null +++ b/COPYING @@ -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. + + + Copyright (C) + + 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. + + , 1 April 1990 + Ty Coon, President of Vice + +That's all there is to it! + + diff --git a/Gtk2HsSetup.hs b/Gtk2HsSetup.hs new file mode 100644 --- /dev/null +++ b/Gtk2HsSetup.hs @@ -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 "" . 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) diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,7 @@ +-- Setup file for a Gtk2Hs module. Contains only adjustments specific to this module, +-- all Gtk2Hs-specific boilerplate is stored in Gtk2HsSetup.hs which should be kept +-- identical across all modules. +import Gtk2HsSetup ( gtk2hsUserHooks ) +import Distribution.Simple ( defaultMainWithHooks ) + +main = defaultMainWithHooks gtk2hsUserHooks diff --git a/System/Glib.hs b/System/Glib.hs new file mode 100644 --- /dev/null +++ b/System/Glib.hs @@ -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 diff --git a/System/Glib/Attributes.hs b/System/Glib/Attributes.hs new file mode 100644 --- /dev/null +++ b/System/Glib/Attributes.hs @@ -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 diff --git a/System/Glib/FFI.hs b/System/Glib/FFI.hs new file mode 100644 --- /dev/null +++ b/System/Glib/FFI.hs @@ -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) diff --git a/System/Glib/Flags.hs b/System/Glib/Flags.hs new file mode 100644 --- /dev/null +++ b/System/Glib/Flags.hs @@ -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) +-} diff --git a/System/Glib/GDateTime.chs b/System/Glib/GDateTime.chs new file mode 100644 --- /dev/null +++ b/System/Glib/GDateTime.chs @@ -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 diff --git a/System/Glib/GError.chs b/System/Glib/GError.chs new file mode 100644 --- /dev/null +++ b/System/Glib/GError.chs @@ -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) diff --git a/System/Glib/GList.chs b/System/Glib/GList.chs new file mode 100644 --- /dev/null +++ b/System/Glib/GList.chs @@ -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 #} + diff --git a/System/Glib/GObject.chs b/System/Glib/GObject.chs new file mode 100644 --- /dev/null +++ b/System/Glib/GObject.chs @@ -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 + diff --git a/System/Glib/GParameter.hsc b/System/Glib/GParameter.hsc new file mode 100644 --- /dev/null +++ b/System/Glib/GParameter.hsc @@ -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 + +--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 diff --git a/System/Glib/GType.chs b/System/Glib/GType.chs new file mode 100644 --- /dev/null +++ b/System/Glib/GType.chs @@ -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) + diff --git a/System/Glib/GTypeConstants.hsc b/System/Glib/GTypeConstants.hsc new file mode 100644 --- /dev/null +++ b/System/Glib/GTypeConstants.hsc @@ -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 + +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 diff --git a/System/Glib/GValue.chs b/System/Glib/GValue.chs new file mode 100644 --- /dev/null +++ b/System/Glib/GValue.chs @@ -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 diff --git a/System/Glib/GValueTypes.chs b/System/Glib/GValueTypes.chs new file mode 100644 --- /dev/null +++ b/System/Glib/GValueTypes.chs @@ -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 + diff --git a/System/Glib/MainLoop.chs b/System/Glib/MainLoop.chs new file mode 100644 --- /dev/null +++ b/System/Glib/MainLoop.chs @@ -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 diff --git a/System/Glib/Properties.chs b/System/Glib/Properties.chs new file mode 100644 --- /dev/null +++ b/System/Glib/Properties.chs @@ -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) diff --git a/System/Glib/Signals.chs b/System/Glib/Signals.chs new file mode 100644 --- /dev/null +++ b/System/Glib/Signals.chs @@ -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 diff --git a/System/Glib/StoreValue.hsc b/System/Glib/StoreValue.hsc new file mode 100644 --- /dev/null +++ b/System/Glib/StoreValue.hsc @@ -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 + +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 diff --git a/System/Glib/Types.chs b/System/Glib/Types.chs new file mode 100644 --- /dev/null +++ b/System/Glib/Types.chs @@ -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 + diff --git a/System/Glib/UTFString.hs b/System/Glib/UTFString.hs new file mode 100644 --- /dev/null +++ b/System/Glib/UTFString.hs @@ -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 diff --git a/System/Glib/Utils.chs b/System/Glib/Utils.chs new file mode 100644 --- /dev/null +++ b/System/Glib/Utils.chs @@ -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 #} diff --git a/System/Glib/hsgclosure.c b/System/Glib/hsgclosure.c new file mode 100644 --- /dev/null +++ b/System/Glib/hsgclosure.c @@ -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 + +#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))); +} diff --git a/System/Glib/hsgclosure.h b/System/Glib/hsgclosure.h new file mode 100644 --- /dev/null +++ b/System/Glib/hsgclosure.h @@ -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 + +GClosure * gtk2hs_closure_new(HsStablePtr callback); diff --git a/glib.cabal b/glib.cabal new file mode 100644 --- /dev/null +++ b/glib.cabal @@ -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