packages feed

haskell-gi-base (empty) → 0.8

raw patch · 20 files changed

+4611/−0 lines, 20 filesdep +basedep +bytestringdep +containerssetup-changed

Dependencies added: base, bytestring, containers, text

Files

+ LICENSE view
@@ -0,0 +1,502 @@+                  GNU LESSER GENERAL PUBLIC LICENSE+                       Version 2.1, February 1999++ Copyright (C) 1991, 1999 Free Software Foundation, Inc.+ 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301  USA+ Everyone is permitted to copy and distribute verbatim copies+ of this license document, but changing it is not allowed.++[This is the first released version of the Lesser GPL.  It also counts+ as the successor of the GNU Library Public License, version 2, hence+ the version number 2.1.]++                            Preamble++  The licenses for most software are designed to take away your+freedom to share and change it.  By contrast, the GNU General Public+Licenses are intended to guarantee your freedom to share and change+free software--to make sure the software is free for all its users.++  This license, the Lesser General Public License, applies to some+specially designated software packages--typically libraries--of the+Free Software Foundation and other authors who decide to use it.  You+can use it too, but we suggest you first think carefully about whether+this license or the ordinary General Public License is the better+strategy to use in any particular case, based on the explanations below.++  When we speak of free software, we are referring to freedom of use,+not price.  Our General Public Licenses are designed to make sure that+you have the freedom to distribute copies of free software (and charge+for this service if you wish); that you receive source code or can get+it if you want it; that you can change the software and use pieces of+it in new free programs; and that you are informed that you can do+these things.++  To protect your rights, we need to make restrictions that forbid+distributors to deny you these rights or to ask you to surrender these+rights.  These restrictions translate to certain responsibilities for+you if you distribute copies of the library or if you modify it.++  For example, if you distribute copies of the library, whether gratis+or for a fee, you must give the recipients all the rights that we gave+you.  You must make sure that they, too, receive or can get the source+code.  If you link other code with the library, you must provide+complete object files to the recipients, so that they can relink them+with the library after making changes to the library and recompiling+it.  And you must show them these terms so they know their rights.++  We protect your rights with a two-step method: (1) we copyright the+library, and (2) we offer you this license, which gives you legal+permission to copy, distribute and/or modify the library.++  To protect each distributor, we want to make it very clear that+there is no warranty for the free library.  Also, if the library is+modified by someone else and passed on, the recipients should know+that what they have is not the original version, so that the original+author's reputation will not be affected by problems that might be+introduced by others.++  Finally, software patents pose a constant threat to the existence of+any free program.  We wish to make sure that a company cannot+effectively restrict the users of a free program by obtaining a+restrictive license from a patent holder.  Therefore, we insist that+any patent license obtained for a version of the library must be+consistent with the full freedom of use specified in this license.++  Most GNU software, including some libraries, is covered by the+ordinary GNU General Public License.  This license, the GNU Lesser+General Public License, applies to certain designated libraries, and+is quite different from the ordinary General Public License.  We use+this license for certain libraries in order to permit linking those+libraries into non-free programs.++  When a program is linked with a library, whether statically or using+a shared library, the combination of the two is legally speaking a+combined work, a derivative of the original library.  The ordinary+General Public License therefore permits such linking only if the+entire combination fits its criteria of freedom.  The Lesser General+Public License permits more lax criteria for linking other code with+the library.++  We call this license the "Lesser" General Public License because it+does Less to protect the user's freedom than the ordinary General+Public License.  It also provides other free software developers Less+of an advantage over competing non-free programs.  These disadvantages+are the reason we use the ordinary General Public License for many+libraries.  However, the Lesser license provides advantages in certain+special circumstances.++  For example, on rare occasions, there may be a special need to+encourage the widest possible use of a certain library, so that it becomes+a de-facto standard.  To achieve this, non-free programs must be+allowed to use the library.  A more frequent case is that a free+library does the same job as widely used non-free libraries.  In this+case, there is little to gain by limiting the free library to free+software only, so we use the Lesser General Public License.++  In other cases, permission to use a particular library in non-free+programs enables a greater number of people to use a large body of+free software.  For example, permission to use the GNU C Library in+non-free programs enables many more people to use the whole GNU+operating system, as well as its variant, the GNU/Linux operating+system.++  Although the Lesser General Public License is Less protective of the+users' freedom, it does ensure that the user of a program that is+linked with the Library has the freedom and the wherewithal to run+that program using a modified version of the Library.++  The precise terms and conditions for copying, distribution and+modification follow.  Pay close attention to the difference between a+"work based on the library" and a "work that uses the library".  The+former contains code derived from the library, whereas the latter must+be combined with the library in order to run.++                  GNU LESSER GENERAL PUBLIC LICENSE+   TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION++  0. This License Agreement applies to any software library or other+program which contains a notice placed by the copyright holder or+other authorized party saying it may be distributed under the terms of+this Lesser General Public License (also called "this License").+Each licensee is addressed as "you".++  A "library" means a collection of software functions and/or data+prepared so as to be conveniently linked with application programs+(which use some of those functions and data) to form executables.++  The "Library", below, refers to any such software library or work+which has been distributed under these terms.  A "work based on the+Library" means either the Library or any derivative work under+copyright law: that is to say, a work containing the Library or a+portion of it, either verbatim or with modifications and/or translated+straightforwardly into another language.  (Hereinafter, translation is+included without limitation in the term "modification".)++  "Source code" for a work means the preferred form of the work for+making modifications to it.  For a library, complete source code means+all the source code for all modules it contains, plus any associated+interface definition files, plus the scripts used to control compilation+and installation of the library.++  Activities other than copying, distribution and modification are not+covered by this License; they are outside its scope.  The act of+running a program using the Library is not restricted, and output from+such a program is covered only if its contents constitute a work based+on the Library (independent of the use of the Library in a tool for+writing it).  Whether that is true depends on what the Library does+and what the program that uses the Library does.++  1. You may copy and distribute verbatim copies of the Library's+complete source code as you receive it, in any medium, provided that+you conspicuously and appropriately publish on each copy an+appropriate copyright notice and disclaimer of warranty; keep intact+all the notices that refer to this License and to the absence of any+warranty; and distribute a copy of this License along with the+Library.++  You may charge a fee for the physical act of transferring a copy,+and you may at your option offer warranty protection in exchange for a+fee.++  2. You may modify your copy or copies of the Library or any portion+of it, thus forming a work based on the Library, and copy and+distribute such modifications or work under the terms of Section 1+above, provided that you also meet all of these conditions:++    a) The modified work must itself be a software library.++    b) You must cause the files modified to carry prominent notices+    stating that you changed the files and the date of any change.++    c) You must cause the whole of the work to be licensed at no+    charge to all third parties under the terms of this License.++    d) If a facility in the modified Library refers to a function or a+    table of data to be supplied by an application program that uses+    the facility, other than as an argument passed when the facility+    is invoked, then you must make a good faith effort to ensure that,+    in the event an application does not supply such function or+    table, the facility still operates, and performs whatever part of+    its purpose remains meaningful.++    (For example, a function in a library to compute square roots has+    a purpose that is entirely well-defined independent of the+    application.  Therefore, Subsection 2d requires that any+    application-supplied function or table used by this function must+    be optional: if the application does not supply it, the square+    root function must still compute square roots.)++These requirements apply to the modified work as a whole.  If+identifiable sections of that work are not derived from the Library,+and can be reasonably considered independent and separate works in+themselves, then this License, and its terms, do not apply to those+sections when you distribute them as separate works.  But when you+distribute the same sections as part of a whole which is a work based+on the Library, the distribution of the whole must be on the terms of+this License, whose permissions for other licensees extend to the+entire whole, and thus to each and every part regardless of who wrote+it.++Thus, it is not the intent of this section to claim rights or contest+your rights to work written entirely by you; rather, the intent is to+exercise the right to control the distribution of derivative or+collective works based on the Library.++In addition, mere aggregation of another work not based on the Library+with the Library (or with a work based on the Library) on a volume of+a storage or distribution medium does not bring the other work under+the scope of this License.++  3. You may opt to apply the terms of the ordinary GNU General Public+License instead of this License to a given copy of the Library.  To do+this, you must alter all the notices that refer to this License, so+that they refer to the ordinary GNU General Public License, version 2,+instead of to this License.  (If a newer version than version 2 of the+ordinary GNU General Public License has appeared, then you can specify+that version instead if you wish.)  Do not make any other change in+these notices.++  Once this change is made in a given copy, it is irreversible for+that copy, so the ordinary GNU General Public License applies to all+subsequent copies and derivative works made from that copy.++  This option is useful when you wish to copy part of the code of+the Library into a program that is not a library.++  4. You may copy and distribute the Library (or a portion or+derivative of it, under Section 2) in object code or executable form+under the terms of Sections 1 and 2 above provided that you accompany+it with the complete corresponding machine-readable source code, which+must be distributed under the terms of Sections 1 and 2 above on a+medium customarily used for software interchange.++  If distribution of object code is made by offering access to copy+from a designated place, then offering equivalent access to copy the+source code from the same place satisfies the requirement to+distribute the source code, even though third parties are not+compelled to copy the source along with the object code.++  5. A program that contains no derivative of any portion of the+Library, but is designed to work with the Library by being compiled or+linked with it, is called a "work that uses the Library".  Such a+work, in isolation, is not a derivative work of the Library, and+therefore falls outside the scope of this License.++  However, linking a "work that uses the Library" with the Library+creates an executable that is a derivative of the Library (because it+contains portions of the Library), rather than a "work that uses the+library".  The executable is therefore covered by this License.+Section 6 states terms for distribution of such executables.++  When a "work that uses the Library" uses material from a header file+that is part of the Library, the object code for the work may be a+derivative work of the Library even though the source code is not.+Whether this is true is especially significant if the work can be+linked without the Library, or if the work is itself a library.  The+threshold for this to be true is not precisely defined by law.++  If such an object file uses only numerical parameters, data+structure layouts and accessors, and small macros and small inline+functions (ten lines or less in length), then the use of the object+file is unrestricted, regardless of whether it is legally a derivative+work.  (Executables containing this object code plus portions of the+Library will still fall under Section 6.)++  Otherwise, if the work is a derivative of the Library, you may+distribute the object code for the work under the terms of Section 6.+Any executables containing that work also fall under Section 6,+whether or not they are linked directly with the Library itself.++  6. As an exception to the Sections above, you may also combine or+link a "work that uses the Library" with the Library to produce a+work containing portions of the Library, and distribute that work+under terms of your choice, provided that the terms permit+modification of the work for the customer's own use and reverse+engineering for debugging such modifications.++  You must give prominent notice with each copy of the work that the+Library is used in it and that the Library and its use are covered by+this License.  You must supply a copy of this License.  If the work+during execution displays copyright notices, you must include the+copyright notice for the Library among them, as well as a reference+directing the user to the copy of this License.  Also, you must do one+of these things:++    a) Accompany the work with the complete corresponding+    machine-readable source code for the Library including whatever+    changes were used in the work (which must be distributed under+    Sections 1 and 2 above); and, if the work is an executable linked+    with the Library, with the complete machine-readable "work that+    uses the Library", as object code and/or source code, so that the+    user can modify the Library and then relink to produce a modified+    executable containing the modified Library.  (It is understood+    that the user who changes the contents of definitions files in the+    Library will not necessarily be able to recompile the application+    to use the modified definitions.)++    b) Use a suitable shared library mechanism for linking with the+    Library.  A suitable mechanism is one that (1) uses at run time a+    copy of the library already present on the user's computer system,+    rather than copying library functions into the executable, and (2)+    will operate properly with a modified version of the library, if+    the user installs one, as long as the modified version is+    interface-compatible with the version that the work was made with.++    c) Accompany the work with a written offer, valid for at+    least three years, to give the same user the materials+    specified in Subsection 6a, above, for a charge no more+    than the cost of performing this distribution.++    d) If distribution of the work is made by offering access to copy+    from a designated place, offer equivalent access to copy the above+    specified materials from the same place.++    e) Verify that the user has already received a copy of these+    materials or that you have already sent this user a copy.++  For an executable, the required form of the "work that uses the+Library" must include any data and utility programs needed for+reproducing the executable from it.  However, as a special exception,+the materials to be distributed need not include anything that is+normally distributed (in either source or binary form) with the major+components (compiler, kernel, and so on) of the operating system on+which the executable runs, unless that component itself accompanies+the executable.++  It may happen that this requirement contradicts the license+restrictions of other proprietary libraries that do not normally+accompany the operating system.  Such a contradiction means you cannot+use both them and the Library together in an executable that you+distribute.++  7. You may place library facilities that are a work based on the+Library side-by-side in a single library together with other library+facilities not covered by this License, and distribute such a combined+library, provided that the separate distribution of the work based on+the Library and of the other library facilities is otherwise+permitted, and provided that you do these two things:++    a) Accompany the combined library with a copy of the same work+    based on the Library, uncombined with any other library+    facilities.  This must be distributed under the terms of the+    Sections above.++    b) Give prominent notice with the combined library of the fact+    that part of it is a work based on the Library, and explaining+    where to find the accompanying uncombined form of the same work.++  8. You may not copy, modify, sublicense, link with, or distribute+the Library except as expressly provided under this License.  Any+attempt otherwise to copy, modify, sublicense, link with, or+distribute the Library is void, and will automatically terminate your+rights under this License.  However, parties who have received copies,+or rights, from you under this License will not have their licenses+terminated so long as such parties remain in full compliance.++  9. You are not required to accept this License, since you have not+signed it.  However, nothing else grants you permission to modify or+distribute the Library or its derivative works.  These actions are+prohibited by law if you do not accept this License.  Therefore, by+modifying or distributing the Library (or any work based on the+Library), you indicate your acceptance of this License to do so, and+all its terms and conditions for copying, distributing or modifying+the Library or works based on it.++  10. Each time you redistribute the Library (or any work based on the+Library), the recipient automatically receives a license from the+original licensor to copy, distribute, link with or modify the Library+subject to these terms and conditions.  You may not impose any further+restrictions on the recipients' exercise of the rights granted herein.+You are not responsible for enforcing compliance by third parties with+this License.++  11. If, as a consequence of a court judgment or allegation of patent+infringement or for any other reason (not limited to patent issues),+conditions are imposed on you (whether by court order, agreement or+otherwise) that contradict the conditions of this License, they do not+excuse you from the conditions of this License.  If you cannot+distribute so as to satisfy simultaneously your obligations under this+License and any other pertinent obligations, then as a consequence you+may not distribute the Library at all.  For example, if a patent+license would not permit royalty-free redistribution of the Library by+all those who receive copies directly or indirectly through you, then+the only way you could satisfy both it and this License would be to+refrain entirely from distribution of the Library.++If any portion of this section is held invalid or unenforceable under any+particular circumstance, the balance of the section is intended to apply,+and the section as a whole is intended to apply in other circumstances.++It is not the purpose of this section to induce you to infringe any+patents or other property right claims or to contest validity of any+such claims; this section has the sole purpose of protecting the+integrity of the free software distribution system which is+implemented by public license practices.  Many people have made+generous contributions to the wide range of software distributed+through that system in reliance on consistent application of that+system; it is up to the author/donor to decide if he or she is willing+to distribute software through any other system and a licensee cannot+impose that choice.++This section is intended to make thoroughly clear what is believed to+be a consequence of the rest of this License.++  12. If the distribution and/or use of the Library is restricted in+certain countries either by patents or by copyrighted interfaces, the+original copyright holder who places the Library under this License may add+an explicit geographical distribution limitation excluding those countries,+so that distribution is permitted only in or among countries not thus+excluded.  In such case, this License incorporates the limitation as if+written in the body of this License.++  13. The Free Software Foundation may publish revised and/or new+versions of the Lesser General Public License from time to time.+Such new versions will be similar in spirit to the present version,+but may differ in detail to address new problems or concerns.++Each version is given a distinguishing version number.  If the Library+specifies a version number of this License which applies to it and+"any later version", you have the option of following the terms and+conditions either of that version or of any later version published by+the Free Software Foundation.  If the Library does not specify a+license version number, you may choose any version ever published by+the Free Software Foundation.++  14. If you wish to incorporate parts of the Library into other free+programs whose distribution conditions are incompatible with these,+write to the author to ask for permission.  For software which is+copyrighted by the Free Software Foundation, write to the Free+Software Foundation; we sometimes make exceptions for this.  Our+decision will be guided by the two goals of preserving the free status+of all derivatives of our free software and of promoting the sharing+and reuse of software generally.++                            NO WARRANTY++  15. BECAUSE THE LIBRARY IS LICENSED FREE OF CHARGE, THERE IS NO+WARRANTY FOR THE LIBRARY, TO THE EXTENT PERMITTED BY APPLICABLE LAW.+EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR+OTHER PARTIES PROVIDE THE LIBRARY "AS IS" WITHOUT WARRANTY OF ANY+KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR+PURPOSE.  THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE+LIBRARY IS WITH YOU.  SHOULD THE LIBRARY PROVE DEFECTIVE, YOU ASSUME+THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION.++  16. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN+WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY+AND/OR REDISTRIBUTE THE LIBRARY AS PERMITTED ABOVE, BE LIABLE TO YOU+FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR+CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE+LIBRARY (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING+RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A+FAILURE OF THE LIBRARY TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF+SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH+DAMAGES.++                     END OF TERMS AND CONDITIONS++           How to Apply These Terms to Your New Libraries++  If you develop a new library, and you want it to be of the greatest+possible use to the public, we recommend making it free software that+everyone can redistribute and change.  You can do so by permitting+redistribution under these terms (or, alternatively, under the terms of the+ordinary General Public License).++  To apply these terms, attach the following notices to the library.  It is+safest to attach them to the start of each source file to most effectively+convey the exclusion of warranty; and each file should have at least the+"copyright" line and a pointer to where the full notice is found.++    <one line to give the library's name and a brief idea of what it does.>+    Copyright (C) <year>  <name of author>++    This library is free software; you can redistribute it and/or+    modify it under the terms of the GNU Lesser General Public+    License as published by the Free Software Foundation; either+    version 2.1 of the License, or (at your option) any later version.++    This library is distributed in the hope that it will be useful,+    but WITHOUT ANY WARRANTY; without even the implied warranty of+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU+    Lesser General Public License for more details.++    You should have received a copy of the GNU Lesser General Public+    License along with this library; if not, write to the Free Software+    Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301  USA++Also add information on how to contact you by electronic and paper mail.++You should also get your employer (if you work as a programmer) or your+school, if any, to sign a "copyright disclaimer" for the library, if+necessary.  Here is a sample; alter the names:++  Yoyodyne, Inc., hereby disclaims all copyright interest in the+  library `Frob' (a library for tweaking knobs) written by James Random Hacker.++  <signature of Ty Coon>, 1 April 1990+  Ty Coon, President of Vice++That's all there is to it!
+ Setup.hs view
@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+import Distribution.Simple+main = defaultMain
+ haskell-gi-base.cabal view
@@ -0,0 +1,50 @@+name:                haskell-gi-base+version:             0.8+synopsis:            Foundation for libraries generated by haskell-gi+description:         Foundation for libraries generated by haskell-gi+homepage:            https://github.com/haskell-gi/haskell-gi-base+license:             LGPL-2.1+                     -- or above+license-file:        LICENSE+author:              Will Thompson,+                     Iñaki García Etxebarria,+                     Jonas Platte+maintainer:          Iñaki García Etxebarria (garetxe@gmail.com)+stability:           Experimental+category:            Development+build-type:          Simple+cabal-version:       >=1.8++source-repository head+  type: git+  location: git://github.com/haskell-gi/haskell-gi-base.git++library+  hs-source-dirs:      src+  exposed-modules:     Data.GI.Base,+                       Data.GI.Base.Attributes,+                       Data.GI.Base.BasicConversions,+                       Data.GI.Base.BasicTypes,+                       Data.GI.Base.Closure,+                       Data.GI.Base.GError,+                       Data.GI.Base.GHashTable,+                       Data.GI.Base.GValue,+                       Data.GI.Base.GVariant,+                       Data.GI.Base.ManagedPtr,+                       Data.GI.Base.GParamSpec,+                       Data.GI.Base.Overloading,+                       Data.GI.Base.Properties,+                       Data.GI.Base.ShortPrelude,+                       Data.GI.Base.Signals,+                       Data.GI.Base.Utils++  pkgconfig-depends:   gobject-2.0 >= 2.36+  build-depends:       base >= 4 && < 5,+                       bytestring,+                       containers,+                       text >= 1.0++  build-tools:         hsc2hs+  extensions:          CPP, ForeignFunctionInterface, DoAndIfThenElse+  ghc-options:         -Wall -fno-warn-missing-signatures -fwarn-incomplete-patterns -fno-warn-name-shadowing+  c-sources:           src/c/hsgclosure.c
+ src/Data/GI/Base.hs view
@@ -0,0 +1,35 @@+{- |+   == Convenience header for basic GObject-Introspection modules++See the documentation for each individual module for a description and+usage help.+-}+module Data.GI.Base+    ( module Data.GI.Base.Attributes+    , module Data.GI.Base.BasicConversions+    , module Data.GI.Base.BasicTypes+    , module Data.GI.Base.Closure+    , module Data.GI.Base.GError+    , module Data.GI.Base.GHashTable+    , module Data.GI.Base.GValue+    , module Data.GI.Base.GVariant+    , module Data.GI.Base.GParamSpec+    , module Data.GI.Base.ManagedPtr+    , module Data.GI.Base.Properties+    , module Data.GI.Base.Signals+    , module Data.GI.Base.Utils+    ) where++import Data.GI.Base.Attributes+import Data.GI.Base.BasicConversions+import Data.GI.Base.BasicTypes+import Data.GI.Base.Closure+import Data.GI.Base.GError+import Data.GI.Base.GHashTable+import Data.GI.Base.GValue+import Data.GI.Base.GVariant+import Data.GI.Base.GParamSpec+import Data.GI.Base.ManagedPtr+import Data.GI.Base.Properties+import Data.GI.Base.Signals+import Data.GI.Base.Utils
+ src/Data/GI/Base/Attributes.hs view
@@ -0,0 +1,241 @@+{-# LANGUAGE GADTs, ScopedTypeVariables, DataKinds, KindSignatures,+  TypeFamilies, TypeOperators, MultiParamTypeClasses, ConstraintKinds,+  UndecidableInstances #-}++-- |+--+-- == Basic attributes interface+--+-- Attributes of an object can be get, set and constructed. For types+-- descending from 'Data.GI.Base.BasicTypes.GObject', properties are+-- encoded in attributes, although attributes are slightly more+-- general (every property of a `Data.GI.Base.BasicTypes.GObject` is an+-- attribute, but we can also have attributes for types not descending+-- from `Data.GI.Base.BasicTypes.GObject`).+--+-- As an example consider a @button@ widget and a property (of the+-- Button class, or any of its parent classes or implemented+-- interfaces) called "label". The simplest way of getting the value+-- of the button is to do+--+-- > value <- getButtonLabel button+--+-- And for setting:+--+-- > setButtonLabel button label+--+-- This mechanism quickly becomes rather cumbersome, for example for+-- setting the "window" property in a DOMDOMWindow in WebKit:+--+-- > win <- getDOMDOMWindowWindow dom+--+-- and perhaps more importantly, one needs to chase down the type+-- which introduces the property:+--+-- > setWidgetSensitive button False+--+-- There is no @setButtonSensitive@, since it is the @Widget@ type+-- that introduces the "sensitive" property.+--+-- == Overloaded attributes+--+-- A much more convenient overloaded attribute resolution API is+-- provided by this module. Getting the value of an object's attribute+-- is straightforward:+--+-- > value <- get button _label+--+-- The definition of @_label@ is simply a 'Proxy' encoding the name of+-- the attribute to get:+--+-- > _label = Proxy :: Proxy "label"+--+-- These proxies can be automatically generated by invoking the code+-- generator with the @-a@ option. The leading underscore is simply so+-- the autogenerated identifiers do not pollute the namespace, but if+-- this is not a concern the autogenerated names (in the autogenerated+-- @GI/Properties.hs@) can be edited as one wishes.+--+-- The syntax for setting or updating an attribute is only slightly more+-- complex. At the simplest level it is just:+--+-- > set button [ _label := value ]+--+-- or for the WebKit example above+--+-- > set dom [_window := win]+--+-- However as the list notation would indicate, you can set or update multiple+-- attributes of the same object in one go:+--+-- > set button [ _label := value, _sensitive := 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 [ _value :~ (+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 also be set during construction of a+-- `Data.GI.Base.BasicTypes.GObject` using `Data.GI.Base.Properties.new`+--+-- > button <- new Button [_label := "Can't touch this!", _sensitive := False]+--+-- In addition for value being set/get having to have the right type,+-- there can be attributes that are read-only, or that can only be set+-- during construction with `Data.GI.Base.Properties.new`, but cannot be+-- `set` afterwards. That these invariants hold is also checked during+-- compile time.+--+module Data.GI.Base.Attributes (+  AttrInfo(..),++  AttrOpTag(..),++  AttrOp(..),+  get,+  set+  ) where++import Data.Proxy (Proxy(..))++import Data.GI.Base.GValue (GValue(..))+import Data.GI.Base.Overloading (ResolveAttribute)++import GHC.TypeLits+import GHC.Exts (Constraint)++infixr 0 :=,:~,:=>,:~>,::=,::~++-- | Info describing an attribute.+class AttrInfo (info :: *) where+    -- | The operations that are allowed on the attribute.+    type AttrAllowedOps info :: [AttrOpTag]+    -- | Constraint on the value being set.+    type AttrSetTypeConstraint info :: * -> Constraint+    -- | Constraint on the type for which we are allowed to+    -- create\/set\/get the attribute.+    type AttrBaseTypeConstraint info :: * -> Constraint+    -- | Type returned by `attrGet`.+    type AttrGetType info+    -- | A string describing the attribute (for error messages).+    type AttrLabel info :: Symbol+    -- | Get the value of the given attribute.+    attrGet :: AttrBaseTypeConstraint info o =>+               proxy info -> o -> IO (AttrGetType info)+    -- | Set the value of the given attribute, after the object having+    -- the attribute has already been created.+    attrSet :: (AttrBaseTypeConstraint info o,+                AttrSetTypeConstraint info b) =>+               proxy info -> o -> b -> IO ()+    -- | Build a `GValue` representing the attribute.+    attrConstruct :: AttrSetTypeConstraint info b =>+                     proxy info -> b -> IO (String, GValue)++-- | Result of checking whether an op is allowed on an attribute.+data OpAllowed tag attrName =+    OpIsAllowed | AttrOpNotAllowed Symbol tag Symbol attrName++-- | Look in the given list to see if the given `AttrOp` is a member,+-- if not return an error type.+type family AttrOpIsAllowed (tag :: AttrOpTag) (ops :: [AttrOpTag]) (label :: Symbol) :: OpAllowed AttrOpTag Symbol where+    AttrOpIsAllowed tag '[] label =+        'AttrOpNotAllowed "Error: operation " tag " not allowed for attribute type " label+    AttrOpIsAllowed tag (tag ': ops) label = 'OpIsAllowed+    AttrOpIsAllowed tag (other ': ops) label = AttrOpIsAllowed tag ops label++-- | Whether a given `AttrOpTag` is allowed on an attribute, given the+-- info type.+type family AttrOpAllowed (tag :: AttrOpTag) (info :: *) :: Constraint where+    AttrOpAllowed tag info =+        AttrOpIsAllowed tag (AttrAllowedOps info) (AttrLabel info) ~ 'OpIsAllowed++-- | Possible operations on an attribute.+data AttrOpTag = AttrGet | AttrSet | AttrConstruct++-- | Constructors for the different operations allowed on an attribute.+data AttrOp obj (tag :: AttrOpTag) where+    -- Assign a value to an attribute+    (:=)  :: (info ~ ResolveAttribute attr obj,+              AttrInfo info,+              AttrBaseTypeConstraint info obj,+              AttrOpAllowed tag info,+              (AttrSetTypeConstraint info) b) =>+             proxy (attr :: Symbol) -> b -> AttrOp obj tag+    -- Assign the result of an IO action to an attribute+    (:=>) :: (info ~ ResolveAttribute attr obj,+              AttrInfo info,+              AttrBaseTypeConstraint info obj,+              AttrOpAllowed tag info,+              (AttrSetTypeConstraint info) b) =>+             proxy (attr :: Symbol) -> IO b -> AttrOp obj tag+    -- Apply an update function to an attribute+    (:~)  :: (info ~ ResolveAttribute attr obj,+              AttrInfo info,+              AttrBaseTypeConstraint info obj,+              tag ~ 'AttrSet,+              AttrOpAllowed 'AttrSet info,+              AttrOpAllowed 'AttrGet info,+              (AttrSetTypeConstraint info) b,+              a ~ (AttrGetType info)) =>+             proxy (attr :: Symbol) -> (a -> b) -> AttrOp obj tag+    -- Apply an IO update function to an attribute+    (:~>) :: (info ~ ResolveAttribute attr obj,+              AttrInfo info,+              AttrBaseTypeConstraint info obj,+              tag ~ 'AttrSet,+              AttrOpAllowed 'AttrSet info,+              AttrOpAllowed 'AttrGet info,+              (AttrSetTypeConstraint info) b,+              a ~ (AttrGetType info)) =>+             proxy (attr :: Symbol) -> (a -> IO b) -> AttrOp obj tag+    -- Assign a value to an attribute with the object as an argument+    (::=) :: (info ~ ResolveAttribute attr obj,+              AttrInfo info,+              AttrBaseTypeConstraint info obj,+              tag ~ 'AttrSet,+              AttrOpAllowed tag info,+              (AttrSetTypeConstraint info) b) =>+             proxy (attr :: Symbol) -> (obj -> b) -> AttrOp obj tag+    -- Apply an update function to an attribute with the object as an+    -- argument+    (::~) :: (info ~ ResolveAttribute attr obj,+              AttrInfo info,+              AttrBaseTypeConstraint info obj,+              tag ~ 'AttrSet,+              AttrOpAllowed 'AttrSet info,+              AttrOpAllowed 'AttrGet info,+              (AttrSetTypeConstraint info) b,+              a ~ (AttrGetType info)) =>+             proxy (attr :: Symbol) -> (obj -> a -> b) -> AttrOp obj tag++-- | Set a number of properties for some object.+set :: forall o. o -> [AttrOp o 'AttrSet] -> IO ()+set obj = mapM_ app+ where+   resolve :: proxy attr -> Proxy (ResolveAttribute attr o)+   resolve _ = Proxy++   app :: AttrOp o 'AttrSet -> IO ()+   app (attr :=  x) = attrSet (resolve attr) obj x+   app (attr :=> x) = x >>= attrSet (resolve attr) obj+   app (attr :~  f) = attrGet (resolve attr) obj >>=+                      \v -> attrSet (resolve attr) obj (f v)+   app (attr :~> f) = attrGet (resolve attr) obj >>= f >>=+                      attrSet (resolve attr) obj+   app (attr ::= f) = attrSet (resolve attr) obj (f obj)+   app (attr ::~ f) = attrGet (resolve attr) obj >>=+                      \v -> attrSet (resolve attr) obj (f obj v)++-- | Get the value of an attribute for an object.+get :: forall info attr obj proxy.+       (info ~ ResolveAttribute attr obj, AttrInfo info,+        (AttrBaseTypeConstraint info) obj,+        AttrOpAllowed 'AttrGet info) =>+        obj -> proxy (attr :: Symbol) -> IO (AttrGetType info)+get o _ = attrGet (Proxy :: Proxy info) o
+ src/Data/GI/Base/BasicConversions.hsc view
@@ -0,0 +1,595 @@+{-# LANGUAGE ScopedTypeVariables #-}+module Data.GI.Base.BasicConversions+    ( gflagsToWord+    , wordToGFlags++    , packGList+    , unpackGList+    , packGSList+    , unpackGSList+    , packGArray+    , unpackGArray+    , unrefGArray+    , packGPtrArray+    , unpackGPtrArray+    , unrefPtrArray+    , packGByteArray+    , unpackGByteArray+    , unrefGByteArray+    , packGHashTable+    , unpackGHashTable+    , unrefGHashTable+    , packByteString+    , packZeroTerminatedByteString+    , unpackByteStringWithLength+    , unpackZeroTerminatedByteString+    , packFileNameArray+    , packZeroTerminatedFileNameArray+    , unpackZeroTerminatedFileNameArray+    , unpackFileNameArrayWithLength+    , packUTF8CArray+    , packZeroTerminatedUTF8CArray+    , unpackUTF8CArrayWithLength+    , unpackZeroTerminatedUTF8CArray+    , packStorableArray+    , packZeroTerminatedStorableArray+    , unpackStorableArrayWithLength+    , unpackZeroTerminatedStorableArray+    , packMapStorableArray+    , packMapZeroTerminatedStorableArray+    , unpackMapStorableArrayWithLength+    , unpackMapZeroTerminatedStorableArray+    , packPtrArray+    , packZeroTerminatedPtrArray+    , unpackPtrArrayWithLength+    , unpackZeroTerminatedPtrArray+    , packBlockArray+    , unpackBlockArrayWithLength+    , unpackBoxedArrayWithLength++    , stringToCString+    , cstringToString+    , textToCString+    , withTextCString+    , cstringToText+    , byteStringToCString+    , cstringToByteString++    , mapZeroTerminatedCArray+    , mapCArrayWithLength+    , mapGArray+    , mapPtrArray+    , mapGList+    , mapGSList+    ) where++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative ((<$>), (<*>))+#endif+import Control.Exception.Base (bracket)+import Control.Monad (foldM)++import Data.ByteString (ByteString)+import qualified Data.ByteString as B+import qualified Data.ByteString.Internal as BI+import Data.Maybe (fromMaybe)+import Data.Text (Text)+import qualified Data.Text.Foreign as TF++import Foreign.Ptr (Ptr, plusPtr, nullPtr, nullFunPtr, castPtr)+import Foreign.ForeignPtr (withForeignPtr)+import Foreign.Storable (Storable, peek, poke, sizeOf)+import Foreign.C.Types (CInt(..), CUInt(..), CSize(..), CChar(..))+import Foreign.C.String (CString, withCString, peekCString)+import Data.Word (Word8, Word64)+import Data.Int (Int32)+import Data.Bits (Bits, (.|.), (.&.), shift)++import Data.GI.Base.BasicTypes+import Data.GI.Base.GHashTable (GEqualFunc, GHashFunc)+import Data.GI.Base.ManagedPtr (copyBoxedPtr)+import Data.GI.Base.Utils (allocBytes, callocBytes, memcpy, freeMem)++#include <glib-object.h>++gflagsToWord :: (Num b, IsGFlag a) => [a] -> b+gflagsToWord flags = fromIntegral (go flags)+    where go (f:fs) = fromEnum f .|. go fs+          go [] = 0++wordToGFlags :: forall a b. (Storable a, Integral a, Bits a, IsGFlag b) =>+                a -> [b]+wordToGFlags w = go 0+    where+      nbits = (sizeOf (undefined :: a))*8+      go k+          | k == nbits = []+          | otherwise = if mask .&. w /= 0+                        then toEnum (fromIntegral mask) : go (k+1)+                        else go (k+1)+          where mask = shift 1 k++foreign import ccall "g_list_prepend" g_list_prepend ::+    Ptr (GList (Ptr a)) -> Ptr a -> IO (Ptr (GList (Ptr a)))++-- Given a Haskell list of items, construct a GList with those values.+packGList   :: [Ptr a] -> IO (Ptr (GList (Ptr a)))+packGList l = foldM g_list_prepend nullPtr $ reverse l++-- Given a GSList construct the corresponding Haskell list.+unpackGList   :: Ptr (GList (Ptr a)) -> IO [Ptr a]+unpackGList gsl+    | gsl == nullPtr = return []+    | otherwise =+        do x <- peek (castPtr gsl)+           next <- peek (gsl `plusPtr` sizeOf x)+           xs <- unpackGList next+           return $ x : xs++-- Same thing for singly linked lists++foreign import ccall "g_slist_prepend" g_slist_prepend ::+    Ptr (GSList (Ptr a)) -> Ptr a -> IO (Ptr (GSList (Ptr a)))++-- Given a Haskell list of items, construct a GSList with those values.+packGSList   :: [Ptr a] -> IO (Ptr (GSList (Ptr a)))+packGSList l = foldM g_slist_prepend nullPtr $ reverse l++-- Given a GSList construct the corresponding Haskell list.+unpackGSList   :: Ptr (GSList (Ptr a)) -> IO [Ptr a]+unpackGSList gsl = unpackGList (castPtr gsl)++foreign import ccall "g_array_new" g_array_new ::+   CInt -> CInt -> CUInt -> IO (Ptr (GArray ()))+foreign import ccall "g_array_set_size" g_array_set_size ::+    Ptr (GArray ()) -> CUInt -> IO (Ptr (GArray ()))+foreign import ccall "g_array_unref" unrefGArray ::+   Ptr (GArray a) -> IO ()++packGArray :: forall a. Storable a => [a] -> IO (Ptr (GArray a))+packGArray elems = do+  let elemsize = sizeOf (elems!!0)+  array <- g_array_new 0 0 (fromIntegral elemsize)+  _ <- g_array_set_size array (fromIntegral $ length elems)+  dataPtr <- peek (castPtr array :: Ptr (Ptr a))+  fill dataPtr elems+  return $ castPtr array+  where+    fill            :: Ptr a -> [a] -> IO ()+    fill _ []       = return ()+    fill ptr (x:xs) =+        do poke ptr x+           fill (ptr `plusPtr` (sizeOf x)) xs++unpackGArray :: forall a. Storable a => Ptr (GArray a) -> IO [a]+unpackGArray array = do+  dataPtr <- peek (castPtr array :: Ptr (Ptr a))+  nitems <- peek (array `plusPtr` sizeOf dataPtr)+  go dataPtr nitems+    where go :: Ptr a -> Int -> IO [a]+          go _ 0 = return []+          go ptr n = do+            x <- peek ptr+            (x:) <$> go (ptr `plusPtr` sizeOf x) (n-1)++foreign import ccall "g_ptr_array_new" g_ptr_array_new ::+    IO (Ptr (GPtrArray ()))+foreign import ccall "g_ptr_array_set_size" g_ptr_array_set_size ::+    Ptr (GPtrArray ()) -> CUInt -> IO (Ptr (GPtrArray ()))+foreign import ccall "g_ptr_array_unref" unrefPtrArray ::+   Ptr (GPtrArray a) -> IO ()++packGPtrArray :: [Ptr a] -> IO (Ptr (GPtrArray (Ptr a)))+packGPtrArray elems = do+  array <- g_ptr_array_new+  _ <- g_ptr_array_set_size array (fromIntegral $ length elems)+  dataPtr <- peek (castPtr array :: Ptr (Ptr (Ptr a)))+  fill dataPtr elems+  return $ castPtr array+  where+    fill            :: Ptr (Ptr a) -> [Ptr a] -> IO ()+    fill _ []       = return ()+    fill ptr (x:xs) =+        do poke ptr x+           fill (ptr `plusPtr` (sizeOf x)) xs++unpackGPtrArray :: Ptr (GPtrArray (Ptr a)) -> IO [Ptr a]+unpackGPtrArray array = do+  dataPtr <- peek (castPtr array :: Ptr (Ptr (Ptr a)))+  nitems <- peek (array `plusPtr` sizeOf dataPtr)+  go dataPtr nitems+    where go :: Ptr (Ptr a) -> Int -> IO [Ptr a]+          go _ 0 = return []+          go ptr n = do+            x <- peek ptr+            (x:) <$> go (ptr `plusPtr` sizeOf x) (n-1)++foreign import ccall "g_byte_array_new" g_byte_array_new ::+    IO (Ptr GByteArray)+foreign import ccall "g_byte_array_append" g_byte_array_append ::+    Ptr GByteArray -> Ptr a -> CUInt -> IO (Ptr GByteArray)+foreign import ccall "g_byte_array_unref" unrefGByteArray ::+   Ptr GByteArray -> IO ()++packGByteArray :: ByteString -> IO (Ptr GByteArray)+packGByteArray bs = do+  array <- g_byte_array_new+  let (ptr, offset, length) = BI.toForeignPtr bs+  _ <- withForeignPtr ptr $ \dataPtr ->+                    g_byte_array_append array (dataPtr `plusPtr` offset)+                                        (fromIntegral length)+  return array++unpackGByteArray :: Ptr GByteArray -> IO ByteString+unpackGByteArray array = do+  dataPtr <- peek (castPtr array :: Ptr (Ptr CChar))+  length <- peek (array `plusPtr` (sizeOf dataPtr)) :: IO CUInt+  B.packCStringLen (dataPtr, fromIntegral length)++foreign import ccall "g_hash_table_new_full" g_hash_table_new_full ::+    GHashFunc a -> GEqualFunc a -> GDestroyNotify a -> GDestroyNotify b ->+                 IO (Ptr (GHashTable a b))+foreign import ccall "g_hash_table_insert" g_hash_table_insert ::+    Ptr (GHashTable a b) -> PtrWrapped a -> PtrWrapped b -> IO #{type gboolean}++packGHashTable :: GHashFunc a -> GEqualFunc a ->+                  Maybe (GDestroyNotify a) -> Maybe (GDestroyNotify b) ->+                  [(PtrWrapped a, PtrWrapped b)] -> IO (Ptr (GHashTable a b))+packGHashTable keyHash keyEqual keyDestroy elemDestroy pairs = do+  let keyDPtr = fromMaybe nullFunPtr keyDestroy+      elemDPtr = fromMaybe nullFunPtr elemDestroy+  ht <- g_hash_table_new_full keyHash keyEqual keyDPtr elemDPtr+  mapM_ (uncurry (g_hash_table_insert ht)) pairs+  return ht++foreign import ccall "g_hash_table_get_keys" g_hash_table_get_keys ::+    Ptr (GHashTable a b) -> IO (Ptr (GList (Ptr a)))+foreign import ccall "g_hash_table_lookup" g_hash_table_lookup ::+    Ptr (GHashTable a b) -> PtrWrapped a -> IO (PtrWrapped b)+unpackGHashTable :: Ptr (GHashTable a b) -> IO [(PtrWrapped a, PtrWrapped b)]+unpackGHashTable ht = do+  keysGList <- g_hash_table_get_keys ht+  keys <- (map (PtrWrapped . castPtr)) <$> unpackGList keysGList+  g_list_free keysGList+  -- At this point we could use g_hash_table_get_values, since the+  -- current implementation in GLib returns elements in the same order+  -- as g_hash_table_get_keys. But to be on the safe side, since the+  -- ordering is not specified in the documentation, we do the+  -- following, which is (quite) slower but manifestly safe.+  elems <- mapM (g_hash_table_lookup ht) keys+  return (zip keys elems)++foreign import ccall "g_hash_table_unref" unrefGHashTable ::+   Ptr (GHashTable a b) -> IO ()++packByteString :: ByteString -> IO (Ptr Word8)+packByteString bs = do+  let (ptr, offset, length) = BI.toForeignPtr bs+  mem <- allocBytes length+  withForeignPtr ptr $ \dataPtr ->+      memcpy mem (dataPtr `plusPtr` offset) (fromIntegral length)+  return mem++packZeroTerminatedByteString :: ByteString -> IO (Ptr Word8)+packZeroTerminatedByteString bs = do+  let (ptr, offset, length) = BI.toForeignPtr bs+  mem <- allocBytes (length+1)+  withForeignPtr ptr $ \dataPtr ->+      memcpy mem (dataPtr `plusPtr` offset) (fromIntegral length)+  poke (mem `plusPtr` (offset+length)) (0 :: Word8)+  return mem++unpackByteStringWithLength :: Integral a => a -> Ptr Word8 -> IO ByteString+unpackByteStringWithLength length ptr =+  B.packCStringLen (castPtr ptr, fromIntegral length)++unpackZeroTerminatedByteString :: Ptr Word8 -> IO ByteString+unpackZeroTerminatedByteString ptr =+  B.packCString (castPtr ptr)++packStorableArray :: Storable a => [a] -> IO (Ptr a)+packStorableArray = packMapStorableArray id++packZeroTerminatedStorableArray :: (Num a, Storable a) => [a] -> IO (Ptr a)+packZeroTerminatedStorableArray = packMapZeroTerminatedStorableArray id++unpackStorableArrayWithLength :: (Integral a, Storable b) =>+                                 a -> Ptr b -> IO [b]+unpackStorableArrayWithLength = unpackMapStorableArrayWithLength id++unpackZeroTerminatedStorableArray :: (Eq a, Num a, Storable a) =>+                                     Ptr a -> IO [a]+unpackZeroTerminatedStorableArray = unpackMapZeroTerminatedStorableArray id++packMapStorableArray :: forall a b. Storable b => (a -> b) -> [a] -> IO (Ptr b)+packMapStorableArray fn items = do+  let nitems = length items+  mem <- allocBytes $ (sizeOf (undefined::b)) * nitems+  fill mem (map fn items)+  return mem+  where fill            :: Ptr b -> [b] -> IO ()+        fill _ []       = return ()+        fill ptr (x:xs) = do+          poke ptr x+          fill (ptr `plusPtr` sizeOf x) xs++packMapZeroTerminatedStorableArray :: forall a b. (Num b, Storable b) =>+                                      (a -> b) -> [a] -> IO (Ptr b)+packMapZeroTerminatedStorableArray fn items = do+  let nitems = length items+  mem <- allocBytes $ (sizeOf (undefined::b)) * (nitems+1)+  fill mem (map fn items)+  return mem+  where fill            :: Ptr b -> [b] -> IO ()+        fill ptr []     = poke ptr 0+        fill ptr (x:xs) = do+          poke ptr x+          fill (ptr `plusPtr` sizeOf x) xs++unpackMapStorableArrayWithLength :: forall a b c. (Integral a, Storable b) =>+                                    (b -> c) -> a -> Ptr b -> IO [c]+unpackMapStorableArrayWithLength fn n ptr = map fn <$> go (fromIntegral n) ptr+    where go :: Int -> Ptr b -> IO [b]+          go 0 _ = return []+          go n ptr = do+            x <- peek ptr+            (x:) <$> go (n-1) (ptr `plusPtr` sizeOf x)++unpackMapZeroTerminatedStorableArray :: forall a b. (Eq a, Num a, Storable a) =>+                                        (a -> b) -> Ptr a -> IO [b]+unpackMapZeroTerminatedStorableArray fn ptr = map fn <$> go ptr+    where go :: Ptr a -> IO [a]+          go ptr = do+            x <- peek ptr+            if x == 0+            then return []+            else (x:) <$> go (ptr `plusPtr` sizeOf x)++packUTF8CArray :: [Text] -> IO (Ptr CString)+packUTF8CArray items = do+  let nitems = length items+  mem <- allocBytes $ nitems * (sizeOf (nullPtr :: CString))+  fill mem items+  return mem+    where fill            :: Ptr CString -> [Text] -> IO ()+          fill _ []       = return ()+          fill ptr (x:xs) =+              do cstring <- textToCString x+                 poke ptr cstring+                 fill (ptr `plusPtr` sizeOf cstring) xs++packZeroTerminatedUTF8CArray :: [Text] -> IO (Ptr CString)+packZeroTerminatedUTF8CArray items = do+    let nitems = length items+    mem <- allocBytes $ (sizeOf (nullPtr :: CString)) * (nitems+1)+    fill mem items+    return mem+    where fill :: Ptr CString -> [Text] -> IO ()+          fill ptr [] = poke ptr nullPtr+          fill ptr (x:xs) = do cstring <- textToCString x+                               poke ptr cstring+                               fill (ptr `plusPtr` sizeOf cstring) xs++unpackZeroTerminatedUTF8CArray :: Ptr CString -> IO [Text]+unpackZeroTerminatedUTF8CArray listPtr = go listPtr+    where go :: Ptr CString -> IO [Text]+          go ptr = do+            cstring <- peek ptr+            if cstring == nullPtr+               then return []+               else (:) <$> cstringToText cstring+                        <*> go (ptr `plusPtr` sizeOf cstring)++unpackUTF8CArrayWithLength :: Integral a => a -> Ptr CString -> IO [Text]+unpackUTF8CArrayWithLength n ptr = go (fromIntegral n) ptr+    where go       :: Int -> Ptr CString -> IO [Text]+          go 0 _   = return []+          go n ptr = do+            cstring <- peek ptr+            (:) <$> cstringToText cstring+                    <*> go (n-1) (ptr `plusPtr` sizeOf cstring)++packFileNameArray :: [String] -> IO (Ptr CString)+packFileNameArray items = do+  let nitems = length items+  mem <- allocBytes $ nitems * (sizeOf (nullPtr :: CString))+  fill mem items+  return mem+    where fill            :: Ptr CString -> [String] -> IO ()+          fill _ []       = return ()+          fill ptr (x:xs) =+              do cstring <- stringToCString x+                 poke ptr cstring+                 fill (ptr `plusPtr` sizeOf cstring) xs++packZeroTerminatedFileNameArray :: [String] -> IO (Ptr CString)+packZeroTerminatedFileNameArray items = do+    let nitems = length items+    mem <- allocBytes $ (sizeOf (nullPtr :: CString)) * (nitems+1)+    fill mem items+    return mem+    where fill :: Ptr CString -> [String] -> IO ()+          fill ptr [] = poke ptr nullPtr+          fill ptr (x:xs) = do cstring <- stringToCString x+                               poke ptr cstring+                               fill (ptr `plusPtr` sizeOf cstring) xs++unpackZeroTerminatedFileNameArray :: Ptr CString -> IO [String]+unpackZeroTerminatedFileNameArray listPtr = go listPtr+    where go :: Ptr CString -> IO [String]+          go ptr = do+            cstring <- peek ptr+            if cstring == nullPtr+               then return []+               else (:) <$> cstringToString cstring+                        <*> go (ptr `plusPtr` sizeOf cstring)++unpackFileNameArrayWithLength :: Integral a =>+                                 a -> Ptr CString -> IO [String]+unpackFileNameArrayWithLength n ptr = go (fromIntegral n) ptr+    where go       :: Int -> Ptr CString -> IO [String]+          go 0 _   = return []+          go n ptr = do+            cstring <- peek ptr+            (:) <$> cstringToString cstring+                    <*> go (n-1) (ptr `plusPtr` sizeOf cstring)++foreign import ccall "g_strdup" g_strdup :: CString -> IO CString++-- We need to use the GLib allocator for constructing CStrings, since+-- the ownership of the string may be transferred to the GLib side,+-- which will free it with g_free.+stringToCString :: String -> IO CString+stringToCString str = withCString str g_strdup++cstringToString :: CString -> IO String+cstringToString = peekCString++foreign import ccall "g_strndup" g_strndup ::+    CString -> #{type gsize} -> IO CString++-- | Convert `Text` into a `CString`, using the GLib allocator.+textToCString :: Text -> IO CString+textToCString str = TF.withCStringLen str $ \(cstr, len) ->+  -- Because withCStringLen returns NULL for a zero-length Text, and+  -- g_strndup returns NULL for NULL, even if n==0.+  if cstr /= nullPtr+  then g_strndup cstr (fromIntegral len)+  else callocBytes 1++withTextCString :: Text -> (CString -> IO a) -> IO a+withTextCString text action = bracket (textToCString text) freeMem action++foreign import ccall "strlen" c_strlen ::+    CString -> IO (CSize)++cstringToText :: CString -> IO Text+cstringToText cstr = do+  len <- c_strlen cstr+  let cstrlen = (cstr, fromIntegral len)+  TF.peekCStringLen cstrlen++byteStringToCString :: ByteString -> IO CString+byteStringToCString bs = B.useAsCString bs g_strdup++cstringToByteString :: CString -> IO ByteString+cstringToByteString = B.packCString++packPtrArray :: [Ptr a] -> IO (Ptr (Ptr a))+packPtrArray items = do+  let nitems = length items+  mem <- allocBytes $ (sizeOf (nullPtr :: Ptr a)) * nitems+  fill mem items+  return mem+  where fill :: Ptr (Ptr a) -> [Ptr a] -> IO ()+        fill _ [] = return ()+        fill ptr (x:xs) = do poke ptr x+                             fill (ptr `plusPtr` sizeOf x) xs++packZeroTerminatedPtrArray :: [Ptr a] -> IO (Ptr (Ptr a))+packZeroTerminatedPtrArray items = do+  let nitems = length items+  mem <- allocBytes $ (sizeOf (nullPtr :: Ptr a)) * (nitems+1)+  fill mem items+  return mem+  where fill            :: Ptr (Ptr a) -> [Ptr a] -> IO ()+        fill ptr []     = poke ptr nullPtr+        fill ptr (x:xs) = do poke ptr x+                             fill (ptr `plusPtr` sizeOf x) xs++unpackPtrArrayWithLength :: Integral a => a -> Ptr (Ptr b) -> IO [Ptr b]+unpackPtrArrayWithLength n ptr = go (fromIntegral n) ptr+    where go       :: Int -> Ptr (Ptr a) -> IO [Ptr a]+          go 0 _   = return []+          go n ptr = (:) <$> peek ptr+                     <*> go (n-1) (ptr `plusPtr` sizeOf (nullPtr :: Ptr a))++unpackZeroTerminatedPtrArray :: Ptr (Ptr a) -> IO [Ptr a]+unpackZeroTerminatedPtrArray ptr = go ptr+    where go :: Ptr (Ptr a) -> IO [Ptr a]+          go ptr = do+            p <- peek ptr+            if p == nullPtr+            then return []+            else (p:) <$> go (ptr `plusPtr` sizeOf p)++mapZeroTerminatedCArray :: (Ptr a -> IO b) -> Ptr (Ptr a) -> IO ()+mapZeroTerminatedCArray f dataPtr+    | (dataPtr == nullPtr) = return ()+    | otherwise =+        do ptr <- peek dataPtr+           if ptr == nullPtr+           then return ()+           else do+             _ <- f ptr+             mapZeroTerminatedCArray f (dataPtr `plusPtr` sizeOf ptr)++packBlockArray :: Int -> [Ptr a] -> IO (Ptr a)+packBlockArray size items = do+  let nitems = length items+  mem <- allocBytes $ size * nitems+  fill mem items+  return mem+  where fill :: Ptr a -> [Ptr a] -> IO ()+        fill _ [] = return ()+        fill ptr (x:xs) = do memcpy ptr x size+                             fill (ptr `plusPtr` size) xs++foreign import ccall "g_memdup" g_memdup ::+    Ptr a -> CUInt -> IO (Ptr a)++unpackBlockArrayWithLength :: Integral a => Int -> a -> Ptr b -> IO [Ptr b]+unpackBlockArrayWithLength size n ptr = go size (fromIntegral n) ptr+    where go       :: Int -> Int -> Ptr b -> IO [Ptr b]+          go _ 0 _   = return []+          go size n ptr = do+            buf <- g_memdup ptr (fromIntegral size)+            (buf :) <$> go size (n-1) (ptr `plusPtr` size)++unpackBoxedArrayWithLength :: forall a b. (Integral a, BoxedObject b) =>+                              Int -> a -> Ptr b -> IO [Ptr b]+unpackBoxedArrayWithLength size n ptr = go size (fromIntegral n) ptr+    where go       :: Int -> Int -> Ptr b -> IO [Ptr b]+          go _ 0 _   = return []+          go size n ptr = do+            buf <- copyBoxedPtr ptr+            (buf :) <$> go size (n-1) (ptr `plusPtr` size)++mapCArrayWithLength :: (Storable a, Integral b) =>+                       b -> (a -> IO c) -> Ptr a -> IO ()+mapCArrayWithLength n f dataPtr+    | (dataPtr == nullPtr) = return ()+    | (n <= 0) = return ()+    | otherwise =+        do ptr <- peek dataPtr+           _ <- f ptr+           mapCArrayWithLength (n-1) f (dataPtr `plusPtr` sizeOf ptr)++mapGArray :: forall a b. Storable a => (a -> IO b) -> Ptr (GArray a) -> IO ()+mapGArray f array+    | (array == nullPtr) = return ()+    | otherwise =+        do dataPtr <- peek (castPtr array :: Ptr (Ptr a))+           nitems <- peek (array `plusPtr` sizeOf dataPtr)+           go dataPtr nitems+               where go :: Ptr a -> Int -> IO ()+                     go _ 0 = return ()+                     go ptr n = do+                       x <- peek ptr+                       _ <- f x+                       go (ptr `plusPtr` sizeOf x) (n-1)++mapPtrArray :: (Ptr a -> IO b) -> Ptr (GPtrArray (Ptr a)) -> IO ()+mapPtrArray f array = mapGArray f (castPtr array)++mapGList :: (Ptr a -> IO b) -> Ptr (GList (Ptr a)) -> IO ()+mapGList f glist+    | (glist == nullPtr) = return ()+    | otherwise =+        do ptr <- peek (castPtr glist)+           next <- peek (glist `plusPtr` sizeOf ptr)+           _ <- f ptr+           mapGList f next++mapGSList :: (Ptr a -> IO b) -> Ptr (GSList (Ptr a)) -> IO ()+mapGSList f gslist = mapGList f (castPtr gslist)
+ src/Data/GI/Base/BasicTypes.hsc view
@@ -0,0 +1,194 @@+{-# LANGUAGE ConstraintKinds, FlexibleContexts, FlexibleInstances #-}+-- | Basic types used in the bindings.+module Data.GI.Base.BasicTypes+    (+      -- * GType related+      GType(..)+    , CGType++    , gtypeName++    , gtypeString+    , gtypePointer+    , gtypeInt32+    , gtypeUInt32+    , gtypeInt64+    , gtypeUInt64+    , gtypeFloat+    , gtypeDouble+    , gtypeBoolean+    , gtypeGType+    , gtypeStrv+    , gtypeBoxed+    , gtypeObject++     -- * Memory management++    , ForeignPtrNewtype+    , BoxedObject(..)+    , BoxedEnum(..)+    , GObject(..)++    -- * Basic GLib \/ GObject types+    , GVariant(..)+    , GParamSpec(..)++    , GArray(..)+    , GPtrArray(..)+    , GByteArray(..)+    , GHashTable(..)+    , GList(..)+    , g_list_free+    , GSList(..)+    , g_slist_free++    , IsGFlag++    , PtrWrapped(..)+    , GDestroyNotify+    ) where++import Data.Coerce (Coercible)+import Data.Word+import Foreign.Ptr (Ptr, FunPtr)+import Foreign.ForeignPtr (ForeignPtr)+import Foreign.C.String (CString, peekCString)++#include <glib-object.h>++-- | A type identifier in the GLib type system. This is the low-level+-- type associated with the representation in memory, when using this+-- on the Haskell side use `GType` below.+type CGType = #type GType++-- | A newtype for use on the haskell side.+newtype GType = GType {gtypeToCGType :: CGType}++foreign import ccall "g_type_name" g_type_name :: GType -> IO CString++-- | Get the name assigned to the given `GType`.+gtypeName :: GType -> IO String+gtypeName gtype = g_type_name gtype >>= peekCString++-- | `GType` of strings.+gtypeString :: GType+gtypeString = GType #const G_TYPE_STRING++-- | `GType` of pointers.+gtypePointer :: GType+gtypePointer = GType #const G_TYPE_POINTER++-- | `GType` for signed integers.+gtypeInt32 :: GType+gtypeInt32 = GType #const G_TYPE_INT++-- | `GType` for unsigned integers.+gtypeUInt32 :: GType+gtypeUInt32 = GType #const G_TYPE_UINT++-- | `GType` for signed 64 bit integers.+gtypeInt64 :: GType+gtypeInt64 = GType #const G_TYPE_INT64++-- | `GType` for unsigned 64 bit integers.+gtypeUInt64 :: GType+gtypeUInt64 = GType #const G_TYPE_UINT64++-- | `GType` for floating point values.+gtypeFloat :: GType+gtypeFloat = GType #const G_TYPE_FLOAT++-- | `GType` for gdouble.+gtypeDouble :: GType+gtypeDouble = GType #const G_TYPE_DOUBLE++-- | `GType` corresponding to gboolean.+gtypeBoolean :: GType+gtypeBoolean = GType #const G_TYPE_BOOLEAN++-- | `GType` corresponding to a `GType` itself.+gtypeGType :: GType+gtypeGType = GType #const G_TYPE_GTYPE++-- | `GType` for a NULL terminated array of strings.+gtypeStrv :: GType+gtypeStrv = GType #const G_TYPE_STRV++-- | `GType` corresponding to a `BoxedObject`.+gtypeBoxed :: GType+gtypeBoxed = GType #const G_TYPE_BOXED++-- | `GType` corresponding to a `GObject`.+gtypeObject :: GType+gtypeObject = GType #const G_TYPE_OBJECT++-- | A constraint ensuring that the given type is coercible to a+-- ForeignPtr. It will hold for newtypes of the form+--+-- > newtype Foo = Foo (ForeignPtr Foo)+--+-- which is the typical shape of wrapped 'GObject's.+type ForeignPtrNewtype a = Coercible a (ForeignPtr ())+-- Notice that the Coercible here is to ForeignPtr (), instead of+-- "ForeignPtr a", which would be the most natural thing. Both are+-- representationally equivalent, so this is not a big deal. This is+-- to work around a problem in ghc 7.10:+-- https://ghc.haskell.org/trac/ghc/ticket/10715++-- | Wrapped boxed structures, identified by their `GType`.+class ForeignPtrNewtype a => BoxedObject a where+    boxedType :: a -> IO GType -- This should not use the value of its+                               -- argument.++-- | Enums with an associated `GType`.+class BoxedEnum a where+    boxedEnumType :: a -> IO GType++-- | A wrapped `GObject`.+class ForeignPtrNewtype a => GObject a where+    -- | Whether the `GObject` is a descendent of <https://developer.gnome.org/gobject/stable/gobject-The-Base-Object-Type.html#GInitiallyUnowned GInitiallyUnowned>.+    gobjectIsInitiallyUnowned :: a -> Bool+    -- | The `GType` for this object.+    gobjectType :: a -> IO GType++-- | A <https://developer.gnome.org/glib/stable/glib-GVariant.html GVariant>. See "Data.GI.Base.GVariant" for further methods.+newtype GVariant = GVariant (ForeignPtr GVariant)++-- | A <https://developer.gnome.org/gobject/stable/gobject-GParamSpec.html GParamSpec>. See "Data.GI.Base.GParamSpec" for further methods.+newtype GParamSpec = GParamSpec (ForeignPtr GParamSpec)++-- | An enum usable as a flag for a function.+class Enum a => IsGFlag a++-- | A <https://developer.gnome.org/glib/stable/glib-Arrays.html GArray>. Marshalling for this type is done in "Data.GI.Base.BasicConversions", it is mapped to a list on the Haskell side.+data GArray a = GArray (Ptr (GArray a))++-- | A <https://developer.gnome.org/glib/stable/glib-Pointer-Arrays.html GPtrArray>. Marshalling for this type is done in "Data.GI.Base.BasicConversions", it is mapped to a list on the Haskell side.+data GPtrArray a = GPtrArray (Ptr (GPtrArray a))++-- | A <https://developer.gnome.org/glib/stable/glib-Byte-Arrays.html GByteArray>. Marshalling for this type is done in "Data.GI.Base.BasicConversions", it is packed to a 'Data.ByteString.ByteString' on the Haskell side.+data GByteArray = GByteArray (Ptr GByteArray)++-- | A <https://developer.gnome.org/glib/stable/glib-Hash-Tables.html GHashTable>. It is mapped to a 'Data.Map.Map' on the Haskell side.+data GHashTable a b = GHashTable (Ptr (GHashTable a b))++-- | A <https://developer.gnome.org/glib/stable/glib-Doubly-Linked-Lists.html GList>, mapped to a list on the Haskell side. Marshalling is done in "Data.GI.Base.BasicConversions".+data GList a = GList (Ptr (GList a))++-- | A <https://developer.gnome.org/glib/stable/glib-Singly-Linked-Lists.html GSList>, mapped to a list on the Haskell side. Marshalling is done in "Data.GI.Base.BasicConversions".+data GSList a = GSList (Ptr (GSList a))++-- | Some APIs, such as `GHashTable`, pass around scalar types+-- wrapped into a pointer. We encode such a type as follows.+newtype PtrWrapped a = PtrWrapped {unwrapPtr :: Ptr a}++-- | Destroy the memory associated with a given pointer.+type GDestroyNotify a = FunPtr (Ptr a -> IO ())++-- | Free the given 'GList'.+foreign import ccall "g_list_free" g_list_free ::+    Ptr (GList a) -> IO ()++-- | Free the given 'GSList'.+foreign import ccall "g_slist_free" g_slist_free ::+    Ptr (GSList a) -> IO ()
+ src/Data/GI/Base/Closure.hs view
@@ -0,0 +1,41 @@+-- Some helper functions to create closures.+module Data.GI.Base.Closure+    ( Closure(..)+    , newCClosure+    , noClosure+    ) where++import Foreign++import Data.GI.Base.BasicTypes+import Data.GI.Base.ManagedPtr (wrapBoxed)+import Data.GI.Base.Utils (safeFreeFunPtrPtr)++newtype Closure = Closure (ForeignPtr Closure)++noClosure :: Maybe Closure+noClosure = Nothing++foreign import ccall "g_closure_get_type" c_g_closure_get_type ::+    IO GType++instance BoxedObject Closure where+    boxedType _ = c_g_closure_get_type+++foreign import ccall "g_cclosure_new" g_cclosure_new+    :: FunPtr a -> Ptr () -> FunPtr c -> IO (Ptr Closure)++foreign import ccall "g_closure_ref" g_closure_ref+    :: Ptr Closure -> IO (Ptr Closure)++foreign import ccall "g_closure_sink" g_closure_sink+    :: Ptr Closure -> IO ()++newCClosure :: FunPtr a -> IO Closure+newCClosure ptr = do+  closure <- g_cclosure_new ptr nullPtr safeFreeFunPtrPtr+  -- The Haskell runtime will manage the memory associated to the+  -- closure, so ref and sink to let GLib know this.+  g_closure_ref closure >>= g_closure_sink+  wrapBoxed Closure closure
+ src/Data/GI/Base/GError.chs view
@@ -0,0 +1,238 @@+{-# LANGUAGE DeriveDataTypeable, ScopedTypeVariables #-}++-- | To catch GError exceptions use the+-- catchGError* or handleGError* functions. They work in a similar+-- way to the standard 'Control.Exception.catch' and+-- 'Control.Exception.handle' functions.+--+-- To catch just a single specific error use 'catchGErrorJust' \/+-- 'handleGErrorJust'. To catch any error in a particular error domain+-- use 'catchGErrorJustDomain' \/ 'handleGErrorJustDomain'+--+-- For convenience, generated code also includes specialized variants+-- of 'catchGErrorJust' \/ 'handleGErrorJust' for each error type. For+-- example, for errors of type 'GI.GdkPixbuf.PixbufError' one could+-- invoke 'GI.GdkPixbuf.catchPixbufError' \/+-- 'GI.GdkPixbuf.handlePixbufError'. The definition is simply+--+-- > catchPixbufError :: IO a -> (PixbufError -> GErrorMessage -> IO a) -> IO a+-- > catchPixbufError = catchGErrorJustDomain+--+-- Notice that the type is suitably specialized, so only+-- errors of type 'GI.GdkPixbuf.PixbufError' will be caught.+module Data.GI.Base.GError+    (+    -- * Unpacking GError+    --+      GError(..)+    , gerrorDomain+    , gerrorCode+    , gerrorMessage++    , GErrorDomain+    , GErrorCode+    , GErrorMessage++    -- * Catching GError exceptions+    , catchGErrorJust+    , catchGErrorJustDomain++    , handleGErrorJust+    , handleGErrorJustDomain++    -- * Creating new 'GError's+    , gerrorNew++    -- * Implementation specific details+    -- | The following are used in the implementation+    -- of the bindings, and are in general not necessary for using the+    -- API.+    , GErrorClass(..)++    , propagateGError+    , checkGError++    ) where++#if __GLASGOW_HASKELL__ < 710+import Control.Applicative ((<$>))+#endif++import Foreign (poke, peek)+import Foreign.ForeignPtr (ForeignPtr, withForeignPtr)+import Foreign.Ptr (Ptr, plusPtr, nullPtr)+import Foreign.C+import Control.Exception+import Data.Text (Text)+import Data.Typeable (Typeable)++import Data.GI.Base.BasicTypes (BoxedObject(..), GType(..))+import Data.GI.Base.BasicConversions (withTextCString, cstringToText)+import Data.GI.Base.ManagedPtr (wrapBoxed)+import Data.GI.Base.Utils (allocMem, freeMem)++#include <glib.h>++-- | A GError, consisting of a domain, code and a human readable+-- message. These can be accessed by 'gerrorDomain', 'gerrorCode' and+-- 'gerrorMessage' below.+newtype GError = GError (ForeignPtr GError)+    deriving (Typeable, Show)++instance Exception GError++foreign import ccall "g_error_get_type" g_error_get_type :: IO GType++instance BoxedObject GError where+    boxedType _ = g_error_get_type++-- | A GQuark.+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 enumeration to use+--   depends on the error domain, but if you use 'catchGErrorJustDomain' or+--   'handleGErrorJustDomain', this is worked out for you automatically.+type GErrorCode = {# type gint #}++-- | A human readable error message.+type GErrorMessage = Text++foreign import ccall "g_error_new_literal" g_error_new_literal ::+    GQuark -> GErrorCode -> CString -> IO (Ptr GError)++-- | Create a new 'GError'.+gerrorNew :: GErrorDomain -> GErrorCode -> GErrorMessage -> IO GError+gerrorNew domain code message =+    withTextCString message $ \cstring ->+        g_error_new_literal domain code cstring >>= wrapBoxed GError++-- | Return the domain for the given `GError`. This is a GQuark, a+-- textual representation can be obtained with+-- `GI.GLib.quarkToString`.+gerrorDomain :: GError -> IO GQuark+gerrorDomain (GError fptr) =+    withForeignPtr fptr $ \ptr ->+      peek $ ptr `plusPtr` {# offsetof GError->domain #}++-- | The numeric code for the given `GError`.+gerrorCode :: GError -> IO GErrorCode+gerrorCode (GError fptr) =+    withForeignPtr fptr $ \ptr ->+        peek $ ptr `plusPtr` {# offsetof GError->code #}++-- | A text message describing the `GError`.+gerrorMessage :: GError -> IO GErrorMessage+gerrorMessage (GError fptr) =+    withForeignPtr fptr $ \ptr ->+      (peek $ ptr `plusPtr` {# offsetof GError->message #}) >>= cstringToText++-- | 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.+--+-- Example for 'GI.GdkPixbuf.PixbufError':+--+-- > instance GErrorClass PixbufError where+-- >   gerrorClassDomain _ = "gdk-pixbuf-error-quark"+--+class Enum err => GErrorClass err where+  gerrorClassDomain :: err -> Text   -- ^ This must not use the value of its+                                     -- parameter so that it is safe to pass+                                     -- 'undefined'.++foreign import ccall unsafe "g_quark_try_string" g_quark_try_string ::+    CString -> IO GQuark++-- | Given the string representation of an error domain returns the+--   corresponding error quark.+gErrorQuarkFromDomain :: Text -> IO GQuark+gErrorQuarkFromDomain domain = withTextCString domain g_quark_try_string++-- | 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 = do+  domainQuark <- gErrorQuarkFromDomain $ gerrorClassDomain code+  catch action (handler' domainQuark)+  where handler' quark gerror = do+          domain <- gerrorDomain gerror+          code' <- gerrorCode gerror+          if domain == quark && code' == (fromIntegral . fromEnum) code+          then gerrorMessage gerror >>= handler+          else throw gerror -- Pass it on++-- | 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 :: forall err a. 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 = do+  domainQuark <- gErrorQuarkFromDomain $ gerrorClassDomain (undefined::err)+  catch action (handler' domainQuark)+  where handler' quark gerror = do+          domain <- gerrorDomain gerror+          if domain == quark+          then do+            code <- (toEnum . fromIntegral) <$> gerrorCode gerror+            msg <- gerrorMessage gerror+            handler code msg+          else throw gerror++-- | 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 'catchGErrorJustDomain' with the arguments swapped around.+handleGErrorJustDomain :: GErrorClass err => (err -> GErrorMessage -> IO a) -> IO a -> IO a+handleGErrorJustDomain = flip catchGErrorJustDomain++-- | Run the given function catching possible 'GError's in its+-- execution. If a 'GError' is emitted this throws the corresponding+-- exception.+propagateGError :: (Ptr (Ptr GError) -> IO a) -> IO a+propagateGError f = checkGError f throw++-- | Like 'propagateGError', but allows to specify a custom handler+-- instead of just throwing the exception.+checkGError :: (Ptr (Ptr GError) -> IO a) -> (GError -> IO a) -> IO a+checkGError f handler = do+  gerrorPtr <- allocMem+  poke gerrorPtr nullPtr+  result <- f gerrorPtr+  gerror <- peek gerrorPtr+  freeMem gerrorPtr+  if gerror /= nullPtr+  then wrapBoxed GError gerror >>= handler+  else return result
+ src/Data/GI/Base/GHashTable.hsc view
@@ -0,0 +1,68 @@+{- | Machinery for some basic support of `GHashTable`.++The GLib `GHashTable` implementation requires two things: we need to+"pack" a datatype into a pointer (for datatypes that are represented+by pointers this is the trivial operation, for integers it is not, and+GLib has some helper macros).++We also need to be able to hash and check for equality different+datatypes.+-}+module Data.GI.Base.GHashTable+    ( GHashFunc+    , GEqualFunc++    , gDirectHash+    , gDirectEqual+    , ptrPackPtr+    , ptrUnpackPtr++    , gStrHash+    , gStrEqual+    , cstringPackPtr+    , cstringUnpackPtr+    ) where++import Data.Int+import Data.Word++import Foreign.C+import Foreign.Ptr (Ptr, castPtr, FunPtr)++import Data.GI.Base.BasicTypes (PtrWrapped(..))++#include <glib-object.h>++-- | A pointer to a hashing function on the C side.+type GHashFunc a = FunPtr (PtrWrapped a -> IO #{type guint})++-- | A pointer to an equality checking function on the C side.+type GEqualFunc a = FunPtr (PtrWrapped a -> PtrWrapped a -> IO #{type gboolean})++-- | Compute the hash for a `Ptr`.+foreign import ccall "&g_direct_hash" gDirectHash :: GHashFunc (Ptr a)++-- | Check whether two pointers are equal.+foreign import ccall "&g_direct_equal" gDirectEqual :: GEqualFunc (Ptr a)++-- | Pack a `Ptr` into a `PtrWrapped` `Ptr`.+ptrPackPtr :: Ptr a -> PtrWrapped (Ptr a)+ptrPackPtr = PtrWrapped . castPtr++-- | Extract a `Ptr` from a `PtrWrapped` `Ptr`.+ptrUnpackPtr :: PtrWrapped (Ptr a) -> Ptr a+ptrUnpackPtr = castPtr . unwrapPtr++-- | Compute the hash for a `CString`.+foreign import ccall "&g_str_hash" gStrHash :: GHashFunc CString++-- | Check whether two `CString`s are equal.+foreign import ccall "&g_str_equal" gStrEqual :: GEqualFunc CString++-- | Pack a `CString` into a `Ptr` than can go into a `GHashTable`.+cstringPackPtr :: CString -> PtrWrapped CString+cstringPackPtr = ptrPackPtr++-- | Extract a `CString` wrapped into a `Ptr` coming from a `GHashTable`.+cstringUnpackPtr :: PtrWrapped CString -> CString+cstringUnpackPtr = ptrUnpackPtr
+ src/Data/GI/Base/GParamSpec.hsc view
@@ -0,0 +1,50 @@+module Data.GI.Base.GParamSpec+    ( noGParamSpec++    , wrapGParamSpecPtr+    , newGParamSpecFromPtr+    , refGParamSpec+    , unrefGParamSpec+    ) where++import Foreign.Ptr+import Foreign.ForeignPtr+import Control.Monad (void)++import Data.GI.Base.BasicTypes (GParamSpec(..))++#include <glib-object.h>++noGParamSpec :: Maybe GParamSpec+noGParamSpec = Nothing++foreign import ccall "g_param_spec_ref_sink" g_param_spec_ref_sink ::+    Ptr GParamSpec -> IO (Ptr GParamSpec)+foreign import ccall "g_param_spec_ref" g_param_spec_ref ::+    Ptr GParamSpec -> IO (Ptr GParamSpec)+foreign import ccall "g_param_spec_unref" g_param_spec_unref ::+    Ptr GParamSpec -> IO ()+foreign import ccall "&g_param_spec_unref" ptr_to_g_param_spec_unref ::+    FunPtr (Ptr GParamSpec -> IO ())++-- | Take ownership of a ParamSpec passed in 'Ptr'.+wrapGParamSpecPtr :: Ptr GParamSpec -> IO GParamSpec+wrapGParamSpecPtr ptr = do+  void $ g_param_spec_ref_sink ptr+  fPtr <- newForeignPtr ptr_to_g_param_spec_unref ptr+  return $! GParamSpec fPtr++-- | Construct a Haskell wrapper for the given 'GParamSpec', without+-- assuming ownership.+newGParamSpecFromPtr :: Ptr GParamSpec -> IO GParamSpec+newGParamSpecFromPtr ptr = do+  fPtr <- g_param_spec_ref ptr >>= newForeignPtr ptr_to_g_param_spec_unref+  return $! GParamSpec fPtr++-- | Add a reference to the given 'GParamSpec'.+refGParamSpec :: GParamSpec -> IO (Ptr GParamSpec)+refGParamSpec (GParamSpec fptr) = withForeignPtr fptr g_param_spec_ref++-- | Remove a reference to the given 'GParamSpec'.+unrefGParamSpec :: GParamSpec -> IO ()+unrefGParamSpec (GParamSpec fptr) = withForeignPtr fptr g_param_spec_unref
+ src/Data/GI/Base/GValue.hsc view
@@ -0,0 +1,307 @@+{-# LANGUAGE FlexibleInstances #-}+module Data.GI.Base.GValue+    ( GValue(..)++    , IsGValue(..)++    , newGValue         -- Build a new, empty, GValue of the given type+    , buildGValue       -- Build a new GValue and initialize to the given value+    , noGValue++    , set_string+    , get_string+    , set_pointer+    , get_pointer+    , set_int32+    , get_int32+    , set_uint32+    , get_uint32+    , set_int64+    , get_int64+    , set_uint64+    , get_uint64+    , set_float+    , get_float+    , set_double+    , get_double+    , set_boolean+    , get_boolean+    , set_gtype+    , get_gtype+    , set_object+    , get_object+    , set_boxed+    , get_boxed+    , set_variant+    , get_variant+    , set_enum+    , get_enum+    , set_flags+    , get_flags+    ) where++#include <glib-object.h>++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative ((<$>))+#endif+import Control.Monad ((>=>))++import Data.Word+import Data.Int+import Data.Text (Text, pack, unpack)++import Foreign.C.Types (CInt(..), CUInt(..), CFloat(..), CDouble(..))+import Foreign.C.String (CString)+import Foreign.Ptr (Ptr)+import Foreign.ForeignPtr (ForeignPtr)++import Data.GI.Base.BasicTypes+import Data.GI.Base.BasicConversions (cstringToText, textToCString)+import Data.GI.Base.ManagedPtr+import Data.GI.Base.Utils (callocBytes, freeMem)++newtype GValue = GValue (ForeignPtr GValue)++noGValue :: Maybe GValue+noGValue = Nothing++foreign import ccall unsafe "g_value_get_type" c_g_value_get_type ::+    IO CGType++instance BoxedObject GValue where+    boxedType _ = GType <$> c_g_value_get_type++foreign import ccall "g_value_init" g_value_init ::+    Ptr GValue -> CGType -> IO (Ptr GValue)++newGValue :: GType -> IO GValue+newGValue (GType gtype) = do+  gvptr <- callocBytes #size GValue+  _ <- g_value_init gvptr gtype+  gv <- wrapBoxed GValue gvptr+  return $! gv++-- Build a new GValue and set the initial value, just for convenience+buildGValue :: GType -> (GValue -> a -> IO ()) -> a -> IO GValue+buildGValue gtype setter val = do+  gv <- newGValue gtype+  setter gv val+  return gv++class IsGValue a where+    toGValue :: a -> IO GValue+    fromGValue :: GValue -> IO a++instance IsGValue String where+    toGValue = buildGValue gtypeString set_string . pack+    fromGValue v = unpack <$> get_string v++instance IsGValue Text where+    toGValue = buildGValue gtypeString set_string+    fromGValue = get_string++instance IsGValue (Ptr a) where+    toGValue = buildGValue gtypePointer set_pointer+    fromGValue = get_pointer++instance IsGValue Int32 where+    toGValue = buildGValue gtypeInt32 set_int32+    fromGValue = get_int32++instance IsGValue Word32 where+    toGValue = buildGValue gtypeUInt32 set_uint32+    fromGValue = get_uint32++instance IsGValue Int64 where+    toGValue = buildGValue gtypeInt64 set_int64+    fromGValue = get_int64++instance IsGValue Word64 where+    toGValue = buildGValue gtypeUInt64 set_uint64+    fromGValue = get_uint64++instance IsGValue Float where+    toGValue = buildGValue gtypeFloat set_float+    fromGValue = get_float++instance IsGValue Double where+    toGValue = buildGValue gtypeDouble set_double+    fromGValue = get_double++instance IsGValue Bool where+    toGValue = buildGValue gtypeBoolean set_boolean+    fromGValue = get_boolean++instance IsGValue GType where+    toGValue = buildGValue gtypeGType set_gtype+    fromGValue = get_gtype++foreign import ccall "g_value_set_string" _set_string ::+    Ptr GValue -> CString -> IO ()+foreign import ccall "g_value_get_string" _get_string ::+    Ptr GValue -> IO CString++set_string :: GValue -> Text -> IO ()+set_string gv str = withManagedPtr gv $ \ptr -> do+                      cstr <- textToCString str+                      _set_string ptr cstr+                      freeMem cstr++get_string :: GValue -> IO Text+get_string gv = withManagedPtr gv $ _get_string >=> cstringToText++foreign import ccall unsafe "g_value_set_pointer" _set_pointer ::+    Ptr GValue -> Ptr a -> IO ()+foreign import ccall unsafe "g_value_get_pointer" _get_pointer ::+    Ptr GValue -> IO (Ptr b)++set_pointer :: GValue -> Ptr a -> IO ()+set_pointer gv ptr = withManagedPtr gv $ flip _set_pointer ptr++get_pointer :: GValue -> IO (Ptr b)+get_pointer gv = withManagedPtr gv _get_pointer++foreign import ccall unsafe "g_value_set_int" _set_int32 ::+    Ptr GValue -> Int32 -> IO ()+foreign import ccall unsafe "g_value_get_int" _get_int32 ::+    Ptr GValue -> IO Int32++set_int32 :: GValue -> Int32 -> IO ()+set_int32 gv n = withManagedPtr gv $ flip _set_int32 n++get_int32 :: GValue -> IO Int32+get_int32 gv = withManagedPtr gv _get_int32++foreign import ccall unsafe "g_value_set_uint" _set_uint32 ::+    Ptr GValue -> Word32 -> IO ()+foreign import ccall unsafe "g_value_get_uint" _get_uint32 ::+    Ptr GValue -> IO Word32++set_uint32 :: GValue -> Word32 -> IO ()+set_uint32 gv n = withManagedPtr gv $ flip _set_uint32 n++get_uint32 :: GValue -> IO Word32+get_uint32 gv = withManagedPtr gv _get_uint32++foreign import ccall unsafe "g_value_set_int64" _set_int64 ::+    Ptr GValue -> Int64 -> IO ()+foreign import ccall unsafe "g_value_get_int64" _get_int64 ::+    Ptr GValue -> IO Int64++set_int64 :: GValue -> Int64 -> IO ()+set_int64 gv n = withManagedPtr gv $ flip _set_int64 n++get_int64 :: GValue -> IO Int64+get_int64 gv = withManagedPtr gv _get_int64++foreign import ccall unsafe "g_value_set_uint64" _set_uint64 ::+    Ptr GValue -> Word64 -> IO ()+foreign import ccall unsafe "g_value_get_uint64" _get_uint64 ::+    Ptr GValue -> IO Word64++set_uint64 :: GValue -> Word64 -> IO ()+set_uint64 gv n = withManagedPtr gv $ flip _set_uint64 n++get_uint64 :: GValue -> IO Word64+get_uint64 gv = withManagedPtr gv _get_uint64++foreign import ccall unsafe "g_value_set_float" _set_float ::+    Ptr GValue -> CFloat -> IO ()+foreign import ccall unsafe "g_value_get_float" _get_float ::+    Ptr GValue -> IO CFloat++set_float :: GValue -> Float -> IO ()+set_float gv f = withManagedPtr gv $ flip _set_float (realToFrac f)++get_float :: GValue -> IO Float+get_float gv = realToFrac <$> withManagedPtr gv _get_float++foreign import ccall unsafe "g_value_set_double" _set_double ::+    Ptr GValue -> CDouble -> IO ()+foreign import ccall unsafe "g_value_get_double" _get_double ::+    Ptr GValue -> IO CDouble++set_double :: GValue -> Double -> IO ()+set_double gv d = withManagedPtr gv $ flip _set_double (realToFrac d)++get_double :: GValue -> IO Double+get_double gv = realToFrac <$> withManagedPtr gv _get_double++foreign import ccall unsafe "g_value_set_boolean" _set_boolean ::+    Ptr GValue -> CInt -> IO ()+foreign import ccall unsafe "g_value_get_boolean" _get_boolean ::+    Ptr GValue -> IO CInt++set_boolean :: GValue -> Bool -> IO ()+set_boolean gv b = withManagedPtr gv $ \ptr ->+                   _set_boolean ptr (fromIntegral $ fromEnum b)++get_boolean :: GValue -> IO Bool+get_boolean gv = withManagedPtr gv $ \ptr -> (/= 0) <$> _get_boolean ptr++foreign import ccall unsafe "g_value_set_gtype" _set_gtype ::+    Ptr GValue -> CGType -> IO ()+foreign import ccall unsafe "g_value_get_gtype" _get_gtype ::+    Ptr GValue -> IO CGType++set_gtype :: GValue -> GType -> IO ()+set_gtype gv (GType g) = withManagedPtr gv $ \ptr -> _set_gtype ptr g++get_gtype :: GValue -> IO GType+get_gtype gv = GType <$> withManagedPtr gv _get_gtype++foreign import ccall "g_value_set_object" _set_object ::+    Ptr GValue -> Ptr a -> IO ()+foreign import ccall "g_value_get_object" _get_object ::+    Ptr GValue -> IO (Ptr a)++set_object :: GObject a => GValue -> Ptr a -> IO ()+set_object gv o = withManagedPtr gv $ flip _set_object o++get_object :: GObject b => GValue -> IO (Ptr b)+get_object gv = withManagedPtr gv _get_object++foreign import ccall "g_value_set_boxed" _set_boxed ::+    Ptr GValue -> Ptr a -> IO ()+foreign import ccall "g_value_get_boxed" _get_boxed ::+    Ptr GValue -> IO (Ptr b)++set_boxed :: GValue -> Ptr a -> IO ()+set_boxed gv b = withManagedPtr gv $ flip _set_boxed b++get_boxed :: GValue -> IO (Ptr b)+get_boxed gv = withManagedPtr gv _get_boxed++foreign import ccall "g_value_set_variant" _set_variant ::+    Ptr GValue -> Ptr GVariant -> IO ()+foreign import ccall "g_value_get_variant" _get_variant ::+    Ptr GValue -> IO (Ptr GVariant)++set_variant :: GValue -> Ptr GVariant -> IO ()+set_variant gv v = withManagedPtr gv $ flip _set_variant v++get_variant :: GValue -> IO (Ptr GVariant)+get_variant gv = withManagedPtr gv _get_variant++foreign import ccall unsafe "g_value_set_enum" _set_enum ::+    Ptr GValue -> CUInt -> IO ()+foreign import ccall unsafe "g_value_get_enum" _get_enum ::+    Ptr GValue -> IO CUInt++set_enum :: GValue -> CUInt -> IO ()+set_enum gv e = withManagedPtr gv $ flip _set_enum e++get_enum :: GValue -> IO CUInt+get_enum gv = withManagedPtr gv _get_enum++foreign import ccall unsafe "g_value_set_flags" _set_flags ::+    Ptr GValue -> CUInt -> IO ()+foreign import ccall unsafe "g_value_get_flags" _get_flags ::+    Ptr GValue -> IO CUInt++set_flags :: GValue -> CUInt -> IO ()+set_flags gv f = withManagedPtr gv $ flip _set_flags f++get_flags :: GValue -> IO CUInt+get_flags gv = withManagedPtr gv _get_flags
+ src/Data/GI/Base/GVariant.hsc view
@@ -0,0 +1,976 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE EmptyDataDecls #-}+{-|+This module contains some helper functions for dealing with GVariant+values. The simplest way of dealing with them is by using the+'IsGVariant' typeclass:++> str <- fromGVariant variant :: IO (Maybe Text)++assuming that the variant is expected to contain a+string in UTF8 encoding. The code becomes even shorter if the type+checker can determine the return type for you:+++> readStringVariant :: GVariant -> IO Text+> readStringVariant variant =+>   fromGVariant variant >>= \case+>      Nothing  -> error "Variant was not a string"+>      Just str -> return str++Alternatively, you can use manually the gvariantFrom* and+gvariantTo* family of functions.+-}+module Data.GI.Base.GVariant+    ( IsGVariant(..)+    , IsGVariantBasicType++    , noGVariant++    , gvariantGetTypeString++    -- * Type wrappers+    -- | Some 'GVariant' types are isomorphic to Haskell types, but they+    -- carry some extra information. For example, there is a tuple+    -- singlet type, which is isomorphic to a single Haskell value+    -- with the added bit of information that it is wrapped in a tuple+    -- container. In order to use these values you can use the+    -- following wrappers, which allow the 'IsGVariant' instance to+    -- disambiguate the requested type properly.++    , GVariantSinglet(GVariantSinglet)+    , GVariantDictEntry(GVariantDictEntry)+    , GVariantHandle(GVariantHandle)+    , GVariantObjectPath+    , newGVariantObjectPath+    , gvariantObjectPathToText+    , GVariantSignature+    , newGVariantSignature+    , gvariantSignatureToText++    -- * Manual memory management++    , wrapGVariantPtr+    , newGVariantFromPtr+    , refGVariant+    , unrefGVariant++    -- * Manual conversions++    -- ** Basic types+    --+    -- | The use of these should be fairly self-explanatory. If you+    -- want to convert a Haskell type into a 'GVariant', use+    -- gvariantTo*. If you want to convert a 'GVariant' into a Haskell+    -- type, use gvariantFrom*. The conversion can fail if the+    -- 'GVariant' is not of the expected type (if you want to convert+    -- a 'GVariant' containing a 'Int16' into a 'Text' value, say), in+    -- which case 'Nothing' will be returned.+    , gvariantToBool+    , gvariantFromBool++    , gvariantToWord8+    , gvariantFromWord8++    , gvariantToInt16+    , gvariantFromInt16++    , gvariantToWord16+    , gvariantFromWord16++    , gvariantToInt32+    , gvariantFromInt32++    , gvariantToWord32+    , gvariantFromWord32++    , gvariantToInt64+    , gvariantFromInt64++    , gvariantToWord64+    , gvariantFromWord64++    , gvariantToHandle+    , gvariantFromHandle++    , gvariantToDouble+    , gvariantFromDouble++    , gvariantToText+    , gvariantFromText++    , gvariantToObjectPath+    , gvariantFromObjectPath++    , gvariantToSignature+    , gvariantFromSignature++    -- ** Container type conversions+    , gvariantToGVariant+    , gvariantFromGVariant++    , gvariantToBytestring+    , gvariantFromBytestring++    , gvariantFromMaybe+    , gvariantToMaybe++    , gvariantFromDictEntry+    , gvariantToDictEntry++    , gvariantFromMap+    , gvariantToMap++    , gvariantFromList+    , gvariantToList++    , gvariantFromTuple+    , gvariantToTuple+    ) where++#include <glib-object.h>++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative ((<$>), (<*>))+#endif+import Control.Monad (when, void, (>=>))+import Control.Exception.Base (bracket)++import Data.Text (Text)+import Data.ByteString (ByteString)+import qualified Data.ByteString as B+import Data.Word+import Data.Int+import Data.Monoid ((<>))+import Data.Maybe (isJust, fromJust)+import qualified Data.Map as M++import System.IO.Unsafe (unsafePerformIO)+import Foreign.C+import Foreign.Ptr+import Foreign.ForeignPtr++import Data.GI.Base.BasicTypes (GVariant(..))+import Data.GI.Base.BasicConversions+import Data.GI.Base.ManagedPtr (withManagedPtr, withManagedPtrList)+import Data.GI.Base.Utils (freeMem)++-- | An alias for @Nothing :: Maybe GVariant@ to save some typing.+noGVariant :: Maybe GVariant+noGVariant = Nothing++-- | The typeclass for types that can be automatically marshalled into+-- 'GVariant' using 'toGVariant' and 'fromGVariant'.+class IsGVariant a where+    -- | Convert a value of the given type into a GVariant.+    toGVariant   :: a -> IO GVariant+    -- | Try to decode a 'GVariant' into a target type. If the+    -- conversion fails we return 'Nothing'. The type that was+    -- expected can be obtained by calling 'toGVariantFormatString',+    -- and the actual type as understood by the 'GVariant' code can be+    -- obtained by calling 'gvariantToTypeString'.+    fromGVariant :: GVariant -> IO (Maybe a)+    -- | The expected format string for this type (the argument is+    -- ignored).+    toGVariantFormatString :: a -> Text++-- Same as fromGVariant, for cases where we have checked that things+-- have the right type in advance.+unsafeFromGVariant :: IsGVariant a => GVariant -> IO a+unsafeFromGVariant gv =+    fromGVariant gv >>= \case+                 Nothing -> error "Error decoding GVariant. This is a bug in haskell-gi, please report it."+                 Just value -> return value++-- | The typeclass for basic type 'GVariant' types, i.e. those that+-- are not containers.+class Ord a => IsGVariantBasicType a++-- | Haskell has no notion of one element tuples, but GVariants do, so+-- the following allows for marshalling one element tuples properly+-- using 'fromGVariant' and 'toGVariant'. For instance, to construct a+-- single element tuple containing a string, you could do+--+-- > toGVariant (GVariantSinglet "Test")+newtype GVariantSinglet a = GVariantSinglet a+    deriving (Eq, Show)++data GVariantType++foreign import ccall "g_variant_type_new" g_variant_type_new ::+    CString -> IO (Ptr GVariantType)++foreign import ccall "g_variant_type_free" g_variant_type_free ::+    Ptr GVariantType -> IO ()++foreign import ccall "g_variant_is_of_type" g_variant_is_of_type ::+    Ptr GVariant -> Ptr GVariantType -> IO #{type gboolean}++withGVariantType :: Text -> (Ptr GVariantType -> IO a) -> IO a+withGVariantType text action = withTextCString text $ \textPtr ->+                               bracket (g_variant_type_new textPtr)+                                       g_variant_type_free+                                       action++gvariantIsOfType :: Text -> GVariant -> IO Bool+gvariantIsOfType typeString variant =+    withGVariantType typeString $+        \typePtr ->+            (toEnum . fromIntegral) <$> withManagedPtr variant+                                        (\vptr -> g_variant_is_of_type+                                                  vptr typePtr)++withExplicitType :: Text -> (Ptr GVariant -> IO a) -> GVariant -> IO (Maybe a)+withExplicitType format action variant = do+  check <- gvariantIsOfType format variant+  if check+  then Just <$> withManagedPtr variant action+  else return Nothing++withTypeCheck :: forall a. (IsGVariant a) =>+                 (Ptr GVariant -> IO a) -> GVariant -> IO (Maybe a)+withTypeCheck = withExplicitType $ toGVariantFormatString (undefined :: a)++foreign import ccall "g_variant_get_type_string" g_variant_get_type_string+    :: Ptr GVariant -> IO CString++-- | Get the expected type of a 'GVariant', in 'GVariant'+-- notation. See+-- <https://developer.gnome.org/glib/stable/glib-GVariantType.html>+-- for the meaning of the resulting format string.+gvariantGetTypeString :: GVariant -> IO Text+gvariantGetTypeString variant =+    withManagedPtr variant (g_variant_get_type_string >=> cstringToText)++foreign import ccall "g_variant_is_floating" g_variant_is_floating ::+    Ptr GVariant -> IO CInt+foreign import ccall "g_variant_ref_sink" g_variant_ref_sink ::+    Ptr GVariant -> IO (Ptr GVariant)+foreign import ccall "g_variant_ref" g_variant_ref ::+    Ptr GVariant -> IO (Ptr GVariant)+foreign import ccall "g_variant_unref" g_variant_unref ::+    Ptr GVariant -> IO ()+foreign import ccall "&g_variant_unref" ptr_to_g_variant_unref ::+    FunPtr (Ptr GVariant -> IO ())++-- | Take ownership of a passed in 'Ptr' (typically created just for+-- us, so if it is floating we sink it).+wrapGVariantPtr :: Ptr GVariant -> IO GVariant+wrapGVariantPtr ptr = do+  floating <- g_variant_is_floating ptr+  when (floating /= 0) $ void $ g_variant_ref_sink ptr+  fPtr <- newForeignPtr ptr_to_g_variant_unref ptr+  return $! GVariant fPtr++-- | Construct a Haskell wrapper for the given 'GVariant', without+-- assuming ownership.+newGVariantFromPtr :: Ptr GVariant -> IO GVariant+newGVariantFromPtr ptr = do+  fPtr <- g_variant_ref ptr >>= newForeignPtr ptr_to_g_variant_unref+  return $! GVariant fPtr++-- | Add a reference to the given 'GVariant'.+refGVariant :: GVariant -> IO (Ptr GVariant)+refGVariant (GVariant fptr) = withForeignPtr fptr g_variant_ref++-- | Remove a reference to the given 'GVariant'.+unrefGVariant :: GVariant -> IO ()+unrefGVariant (GVariant fptr) = withForeignPtr fptr g_variant_unref++instance IsGVariant Bool where+    toGVariant = gvariantFromBool+    fromGVariant = gvariantToBool+    toGVariantFormatString _ = "b"+instance IsGVariantBasicType Bool++foreign import ccall "g_variant_new_boolean" new_bool+    :: #{type gboolean} -> IO (Ptr GVariant)++gvariantFromBool :: Bool -> IO GVariant+gvariantFromBool = (new_bool . fromIntegral . fromEnum) >=> wrapGVariantPtr++foreign import ccall "g_variant_get_boolean" get_bool+    :: Ptr GVariant -> IO #{type gboolean}++gvariantToBool :: GVariant -> IO (Maybe Bool)+gvariantToBool = withTypeCheck $ get_bool >=> (return . toEnum . fromIntegral)++instance IsGVariant Word8 where+    toGVariant = gvariantFromWord8+    fromGVariant = gvariantToWord8+    toGVariantFormatString _ = "y"+instance IsGVariantBasicType Word8++foreign import ccall "g_variant_new_byte" new_byte+    :: #{type guchar} -> IO (Ptr GVariant)++gvariantFromWord8 :: Word8 -> IO GVariant+gvariantFromWord8 = (new_byte . fromIntegral) >=> wrapGVariantPtr++foreign import ccall "g_variant_get_byte" get_byte+    :: Ptr GVariant -> IO #{type guchar}++gvariantToWord8 :: GVariant -> IO (Maybe Word8)+gvariantToWord8 = withTypeCheck $ get_byte >=> (return . fromIntegral)++instance IsGVariant Int16 where+    toGVariant = gvariantFromInt16+    fromGVariant = gvariantToInt16+    toGVariantFormatString _ = "n"+instance IsGVariantBasicType Int16++foreign import ccall "g_variant_new_int16" new_int16+    :: #{type gint16} -> IO (Ptr GVariant)++gvariantFromInt16 :: Int16 -> IO GVariant+gvariantFromInt16 = (new_int16 . fromIntegral) >=> wrapGVariantPtr++foreign import ccall "g_variant_get_int16" get_int16+    :: Ptr GVariant -> IO #{type gint16}++gvariantToInt16 :: GVariant -> IO (Maybe Int16)+gvariantToInt16 = withTypeCheck $ get_int16 >=> (return . fromIntegral)++instance IsGVariant Word16 where+    toGVariant = gvariantFromWord16+    fromGVariant = gvariantToWord16+    toGVariantFormatString _ = "q"+instance IsGVariantBasicType Word16++foreign import ccall "g_variant_new_uint16" new_uint16+    :: #{type guint16} -> IO (Ptr GVariant)++gvariantFromWord16 :: Word16 -> IO GVariant+gvariantFromWord16 = new_uint16 . fromIntegral >=> wrapGVariantPtr++foreign import ccall "g_variant_get_uint16" get_uint16+    :: Ptr GVariant -> IO #{type guint16}++gvariantToWord16 :: GVariant -> IO (Maybe Word16)+gvariantToWord16 = withTypeCheck $ get_uint16 >=> (return . fromIntegral)++instance IsGVariant Int32 where+    toGVariant = gvariantFromInt32+    fromGVariant = gvariantToInt32+    toGVariantFormatString _ = "i"+instance IsGVariantBasicType Int32++foreign import ccall "g_variant_new_int32" new_int32+    :: #{type gint16} -> IO (Ptr GVariant)++gvariantFromInt32 :: Int32 -> IO GVariant+gvariantFromInt32 = (new_int32 . fromIntegral) >=> wrapGVariantPtr++foreign import ccall "g_variant_get_int32" get_int32+    :: Ptr GVariant -> IO #{type gint32}++gvariantToInt32 :: GVariant -> IO (Maybe Int32)+gvariantToInt32 = withTypeCheck $ get_int32 >=> (return . fromIntegral)++instance IsGVariant Word32 where+    toGVariant = gvariantFromWord32+    fromGVariant = gvariantToWord32+    toGVariantFormatString _ = "u"+instance IsGVariantBasicType Word32++foreign import ccall "g_variant_new_uint32" new_uint32+    :: #{type guint32} -> IO (Ptr GVariant)++gvariantFromWord32 :: Word32 -> IO GVariant+gvariantFromWord32 = (new_uint32 . fromIntegral) >=> wrapGVariantPtr++foreign import ccall "g_variant_get_uint32" get_uint32+    :: Ptr GVariant -> IO #{type guint32}++gvariantToWord32 :: GVariant -> IO (Maybe Word32)+gvariantToWord32 = withTypeCheck $ get_uint32 >=> (return . fromIntegral)++instance IsGVariant Int64 where+    toGVariant = gvariantFromInt64+    fromGVariant = gvariantToInt64+    toGVariantFormatString _ = "x"+instance IsGVariantBasicType Int64++foreign import ccall "g_variant_new_int64" new_int64+    :: #{type gint64} -> IO (Ptr GVariant)++gvariantFromInt64 :: Int64 -> IO GVariant+gvariantFromInt64 = (new_int64 . fromIntegral) >=> wrapGVariantPtr++foreign import ccall "g_variant_get_int64" get_int64+    :: Ptr GVariant -> IO #{type gint64}++gvariantToInt64 :: GVariant -> IO (Maybe Int64)+gvariantToInt64 = withTypeCheck $ get_int64 >=> (return . fromIntegral)++instance IsGVariant Word64 where+    toGVariant = gvariantFromWord64+    fromGVariant = gvariantToWord64+    toGVariantFormatString _ = "t"+instance IsGVariantBasicType Word64++foreign import ccall "g_variant_new_uint64" new_uint64+    :: #{type guint64} -> IO (Ptr GVariant)++gvariantFromWord64 :: Word64 -> IO GVariant+gvariantFromWord64 = (new_uint64 . fromIntegral) >=> wrapGVariantPtr++foreign import ccall "g_variant_get_uint64" get_uint64+    :: Ptr GVariant -> IO #{type guint64}++gvariantToWord64 :: GVariant -> IO (Maybe Word64)+gvariantToWord64 = withTypeCheck $ get_uint64 >=> (return . fromIntegral)++newtype GVariantHandle = GVariantHandle Int32+    deriving (Eq, Ord, Show)++instance IsGVariant GVariantHandle where+    toGVariant (GVariantHandle h) = gvariantFromHandle h+    fromGVariant = gvariantToHandle >=> (return . (GVariantHandle <$>))+    toGVariantFormatString _ = "h"+instance IsGVariantBasicType GVariantHandle++foreign import ccall "g_variant_new_handle" new_handle+    :: #{type gint32} -> IO (Ptr GVariant)++-- | Convert a DBus handle (an 'Int32') into a 'GVariant'.+gvariantFromHandle :: Int32 -> IO GVariant+gvariantFromHandle h = (new_handle . fromIntegral) h >>= wrapGVariantPtr++foreign import ccall "g_variant_get_handle" get_handle+    :: Ptr GVariant -> IO #{type gint32}++-- | Extract the DBus handle (an 'Int32') inside a 'GVariant'.+gvariantToHandle :: GVariant -> IO (Maybe Int32)+gvariantToHandle =+  withExplicitType (toGVariantFormatString (undefined :: GVariantHandle)) $+                   get_handle >=> (return . fromIntegral)++instance IsGVariant Double where+    toGVariant = gvariantFromDouble+    fromGVariant = gvariantToDouble+    toGVariantFormatString _ = "d"+instance IsGVariantBasicType Double++foreign import ccall "g_variant_new_double" new_double+    :: #{type gdouble} -> IO (Ptr GVariant)++gvariantFromDouble :: Double -> IO GVariant+gvariantFromDouble = (new_double . realToFrac) >=> wrapGVariantPtr++foreign import ccall "g_variant_get_double" get_double+    :: Ptr GVariant -> IO #{type gdouble}++gvariantToDouble :: GVariant -> IO (Maybe Double)+gvariantToDouble = withTypeCheck $ get_double >=> (return . realToFrac)++instance IsGVariant Text where+    toGVariant = gvariantFromText+    fromGVariant = gvariantToText+    toGVariantFormatString _ = "s"+instance IsGVariantBasicType Text++foreign import ccall "g_variant_get_string" _get_string+    :: Ptr GVariant -> Ptr #{type gsize} -> IO CString++get_string :: Ptr GVariant -> IO CString+get_string v = _get_string v nullPtr++-- | Decode an UTF-8 encoded string 'GVariant' into 'Text'.+gvariantToText :: GVariant -> IO (Maybe Text)+gvariantToText = withTypeCheck $ get_string >=> cstringToText++foreign import ccall "g_variant_new_take_string" take_string+    :: CString -> IO (Ptr GVariant)++-- | Encode a 'Text' into an UTF-8 encoded string 'GVariant'.+gvariantFromText :: Text -> IO GVariant+gvariantFromText = textToCString >=> take_string >=> wrapGVariantPtr++foreign import ccall "g_variant_is_object_path" g_variant_is_object_path ::+    CString -> IO #{type gboolean}++-- | An object representing a DBus object path, which is a particular+-- type of 'GVariant' too. (Just a string with some specific+-- requirements.) In order to construct/deconstruct a+-- 'GVariantObjectPath' one can use 'newGVariantObjectPath'+-- and 'gvariantObjectPathToText'.+newtype GVariantObjectPath = GVariantObjectPath Text+    deriving (Ord, Eq, Show)++-- | Try to construct a DBus object path. If the passed string is not+-- a valid object path 'Nothing' will be returned.+newGVariantObjectPath :: Text -> Maybe GVariantObjectPath+newGVariantObjectPath p = unsafePerformIO $+   withTextCString p $ \cstr -> do+     isObjectPath <- toEnum . fromIntegral <$> g_variant_is_object_path cstr+     if isObjectPath+     then return $ Just (GVariantObjectPath p)+     else return Nothing++-- | Return the 'Text' representation of a 'GVariantObjectPath'.+gvariantObjectPathToText :: GVariantObjectPath -> Text+gvariantObjectPathToText (GVariantObjectPath p) = p++instance IsGVariant GVariantObjectPath where+    toGVariant = gvariantFromObjectPath+    fromGVariant = gvariantToObjectPath >=> return . (GVariantObjectPath <$>)+    toGVariantFormatString _ = "o"+instance IsGVariantBasicType GVariantObjectPath++foreign import ccall "g_variant_new_object_path" new_object_path+    :: CString -> IO (Ptr GVariant)++-- | Construct a 'GVariant' containing an object path. In order to+-- build a 'GVariantObjectPath' value see 'newGVariantObjectPath'.+gvariantFromObjectPath :: GVariantObjectPath -> IO GVariant+gvariantFromObjectPath (GVariantObjectPath p) =+    withTextCString p $ new_object_path >=> wrapGVariantPtr++-- | Extract a 'GVariantObjectPath' from a 'GVariant', represented as+-- its underlying 'Text' representation.+gvariantToObjectPath :: GVariant -> IO (Maybe Text)+gvariantToObjectPath =+    withExplicitType (toGVariantFormatString (undefined :: GVariantObjectPath))+                         (get_string >=> cstringToText)++foreign import ccall "g_variant_is_signature" g_variant_is_signature ::+    CString -> IO #{type gboolean}++-- | An object representing a DBus signature, which is a particular+-- type of 'GVariant' too. (Just a string with some specific+-- requirements.) In order to construct/deconstruct a+-- 'GVariantSignature' one can use 'newGVariantSignature' and+-- 'gvariantSignatureToText'.+newtype GVariantSignature = GVariantSignature Text+    deriving (Ord, Eq, Show)++-- | Try to construct a DBus object path. If the passed string is not+-- a valid DBus signature 'Nothing' will be returned.+newGVariantSignature :: Text -> Maybe GVariantSignature+newGVariantSignature p = unsafePerformIO $+   withTextCString p $ \cstr -> do+     isSignature <- toEnum . fromIntegral <$> g_variant_is_signature cstr+     if isSignature+     then return $ Just (GVariantSignature p)+     else return Nothing++-- | Return the 'Text' representation of a 'GVariantSignature'.+gvariantSignatureToText :: GVariantSignature -> Text+gvariantSignatureToText (GVariantSignature p) = p++instance IsGVariant GVariantSignature where+    toGVariant = gvariantFromSignature+    fromGVariant = gvariantToSignature >=> return . (GVariantSignature <$>)+    toGVariantFormatString _ = "g"+instance IsGVariantBasicType GVariantSignature++foreign import ccall "g_variant_new_signature" new_signature+    :: CString -> IO (Ptr GVariant)++-- | Construct a 'GVariant' containing an DBus signature. In order to+-- build a 'GVariantSignature' value see 'newGVariantSignature'.+gvariantFromSignature :: GVariantSignature -> IO GVariant+gvariantFromSignature (GVariantSignature p) =+    withTextCString p $ new_signature >=> wrapGVariantPtr++-- | Extract a 'GVariantSignature' from a 'GVariant', represented as+-- 'Text'.+gvariantToSignature :: GVariant -> IO (Maybe Text)+gvariantToSignature =+    withExplicitType (toGVariantFormatString (undefined :: GVariantSignature))+                         $ get_string >=> cstringToText++instance IsGVariant GVariant where+    toGVariant = gvariantFromGVariant+    fromGVariant = gvariantToGVariant+    toGVariantFormatString _ = "v"++foreign import ccall "g_variant_new_variant" new_variant+    :: Ptr GVariant -> IO (Ptr GVariant)++-- | Box a 'GVariant' inside another 'GVariant'.+gvariantFromGVariant :: GVariant -> IO GVariant+gvariantFromGVariant v = withManagedPtr v $ new_variant >=> wrapGVariantPtr++foreign import ccall "g_variant_get_variant" get_variant+    :: Ptr GVariant -> IO (Ptr GVariant)++-- | Unbox a 'GVariant' contained inside another 'GVariant'.+gvariantToGVariant :: GVariant -> IO (Maybe GVariant)+gvariantToGVariant = withTypeCheck $ get_variant >=> wrapGVariantPtr++instance IsGVariant ByteString where+    toGVariant = gvariantFromBytestring+    fromGVariant = gvariantToBytestring+    toGVariantFormatString _ = "ay"++foreign import ccall "g_variant_get_bytestring" get_bytestring+    :: Ptr GVariant -> IO CString++-- | Extract a zero terminated list of bytes into a 'ByteString'.+gvariantToBytestring :: GVariant -> IO (Maybe ByteString)+gvariantToBytestring = withTypeCheck (get_bytestring >=> cstringToByteString)++foreign import ccall "g_variant_new_bytestring" new_bytestring+    :: CString -> IO (Ptr GVariant)++-- | Encode a 'ByteString' into a list of bytes 'GVariant'.+gvariantFromBytestring :: ByteString -> IO GVariant+gvariantFromBytestring bs = wrapGVariantPtr =<<+                              B.useAsCString bs new_bytestring+++foreign import ccall "g_variant_n_children" g_variant_n_children+    :: Ptr GVariant -> IO #{type gsize}++foreign import ccall "g_variant_get_child_value" g_variant_get_child_value+    :: Ptr GVariant -> #{type gsize} -> IO (Ptr GVariant)++-- No type checking is done here, it is assumed that the caller knows+-- that the passed variant is indeed of a container type.+gvariant_get_children :: (Ptr GVariant) -> IO [GVariant]+gvariant_get_children vptr = do+      n_children <- g_variant_n_children vptr+      mapM ((g_variant_get_child_value vptr) >=> wrapGVariantPtr)+               [0..(n_children-1)]++instance IsGVariant a => IsGVariant (Maybe a) where+    toGVariant   = gvariantFromMaybe+    fromGVariant = gvariantToMaybe+    toGVariantFormatString _ = "m" <> toGVariantFormatString (undefined :: a)++foreign import ccall "g_variant_new_maybe" g_variant_new_maybe ::+    Ptr GVariantType -> Ptr GVariant -> IO (Ptr GVariant)++-- | Convert a 'Maybe' value into a corresponding 'GVariant' of maybe+-- type.+gvariantFromMaybe :: forall a. IsGVariant a => Maybe a -> IO GVariant+gvariantFromMaybe m = do+  let fmt = toGVariantFormatString (undefined :: a)+  withGVariantType fmt $ \tPtr ->+      case m of+        Just child -> do+               childVariant <- toGVariant child+               withManagedPtr childVariant+                      (g_variant_new_maybe tPtr >=> wrapGVariantPtr)+        Nothing -> g_variant_new_maybe tPtr nullPtr >>= wrapGVariantPtr++-- | Try to decode a maybe 'GVariant' into the corresponding 'Maybe'+-- type. If the conversion is successful this returns @Just x@, where+-- @x@ itself is of 'Maybe' type. So, in particular, @Just Nothing@+-- indicates a successful call, and means that the GVariant of maybe+-- type was empty.+gvariantToMaybe :: forall a. IsGVariant a => GVariant -> IO (Maybe (Maybe a))+gvariantToMaybe v = do+  let fmt = toGVariantFormatString (undefined :: Maybe a)+  withExplicitType fmt gvariant_get_children v >>=+   \case+     Just [] -> return (Just Nothing)+     Just [child] -> fromGVariant child >>=+                     \case+                       Nothing -> return Nothing+                       Just result -> return (Just (Just result))+     Just _ -> error "gvariantToMaybe :: the impossible happened, this is a bug."+     Nothing -> return Nothing++-- | A DictEntry 'GVariant' is isomorphic to a two-tuple. Wrapping the+-- values into a 'GVariantDictentry' allows the 'IsGVariant' instance+-- to do the right thing.+data GVariantDictEntry key value = GVariantDictEntry key value+                                   deriving (Eq, Show)++instance (IsGVariant a, IsGVariantBasicType a, IsGVariant b) =>+    IsGVariant (GVariantDictEntry a b) where+        toGVariant (GVariantDictEntry key value) =+            gvariantFromDictEntry key value+        fromGVariant gv =+            ((uncurry GVariantDictEntry) <$>) <$> gvariantToDictEntry gv+        toGVariantFormatString _ = "{"+                                   <> toGVariantFormatString (undefined :: a)+                                   <> toGVariantFormatString (undefined :: b)+                                   <> "}"++foreign import ccall "g_variant_new_dict_entry" g_variant_new_dict_entry ::+    Ptr GVariant -> Ptr GVariant -> IO (Ptr GVariant)++-- | Construct a 'GVariant' of type DictEntry from the given 'key' and+-- 'value'. The key must be a basic 'GVariant' type, i.e. not a+-- container. This is determined by whether it belongs to the+-- 'IsGVariantBasicType' typeclass. On the other hand 'value' is an+-- arbitrary 'GVariant', and in particular it can be a container type.+gvariantFromDictEntry :: (IsGVariant key, IsGVariantBasicType key,+                          IsGVariant value) =>+                         key -> value -> IO GVariant+gvariantFromDictEntry key value = do+  keyVar <- toGVariant key+  valueVar <- toGVariant value+  withManagedPtr keyVar $ \keyPtr ->+      withManagedPtr valueVar $ \valuePtr ->+          g_variant_new_dict_entry keyPtr valuePtr >>= wrapGVariantPtr++-- | Unpack a DictEntry variant into 'key' and 'value', which are+-- returned as a two element tuple in case of success.+gvariantToDictEntry :: forall key value.+                       (IsGVariant key, IsGVariantBasicType key,+                        IsGVariant value) =>+                       GVariant -> IO (Maybe (key, value))+gvariantToDictEntry =+    withExplicitType fmt $ \varPtr -> do+      [key, value] <- gvariant_get_children varPtr+      (,) <$> unsafeFromGVariant key <*> unsafeFromGVariant value+    where+      fmt = toGVariantFormatString (undefined :: GVariantDictEntry key value)++instance (IsGVariant a, IsGVariantBasicType a, IsGVariant b) =>+    IsGVariant (M.Map a b) where+        toGVariant = gvariantFromMap+        fromGVariant = gvariantToMap+        toGVariantFormatString _ = "a{"+                                   <> toGVariantFormatString (undefined :: a)+                                   <> toGVariantFormatString (undefined :: b)+                                   <> "}"++-- | Pack a 'Map' into a 'GVariant' for dictionary type, which is just+-- an array of 'GVariantDictEntry'.+gvariantFromMap :: (IsGVariant key, IsGVariantBasicType key,+                    IsGVariant value) =>+                   M.Map key value -> IO GVariant+gvariantFromMap m = gvariantFromList $+                       map (uncurry GVariantDictEntry) (M.toList m)++-- | Unpack a 'GVariant' into a 'M.Map'. Notice that this assumes that+-- all the elements in the 'GVariant' array of 'GVariantDictEntry' are+-- of the same type, which is not necessary for a generic 'GVariant',+-- so this is somewhat restrictive. For the general case it is+-- necessary to use 'gvariantToList' plus 'gvariantToDictEntry'+-- directly.+gvariantToMap :: forall key value.+                 (IsGVariant key, IsGVariantBasicType key,+                  IsGVariant value) =>+                 GVariant -> IO (Maybe (M.Map key value))+gvariantToMap = gvariantToList >=> (return . (fromDictEntryList <$>))+    where fromDictEntryList :: [GVariantDictEntry key value] ->+                               M.Map key value+          fromDictEntryList = M.fromList . (map tuplefy)+          tuplefy :: GVariantDictEntry key value -> (key, value)+          tuplefy (GVariantDictEntry key value) = (key, value)++instance IsGVariant a => IsGVariant [a] where+    toGVariant   = gvariantFromList+    fromGVariant = gvariantToList+    toGVariantFormatString _ = "a" <> toGVariantFormatString (undefined :: a)++foreign import ccall "g_variant_new_array" g_variant_new_array ::+    Ptr GVariantType -> Ptr (Ptr GVariant) -> #{type gsize} -> IO (Ptr GVariant)++-- | Given a list of elements construct a 'GVariant' array containing+-- them.+gvariantFromList :: forall a. IsGVariant a => [a] -> IO GVariant+gvariantFromList children = do+  let fmt = toGVariantFormatString (undefined :: a)+  mapM toGVariant children >>= \childVariants ->+      withManagedPtrList childVariants $ \childrenPtrs -> do+          withGVariantType fmt $ \childType -> do+             packed <- packPtrArray childrenPtrs+             result <- g_variant_new_array childType packed+                            (fromIntegral $ length children)+             freeMem packed+             wrapGVariantPtr result++-- | Unpack a 'GVariant' array into its elements.+gvariantToList :: forall a. IsGVariant a => GVariant -> IO (Maybe [a])+gvariantToList = withExplicitType (toGVariantFormatString (undefined :: [a]))+                 (gvariant_get_children >=> mapM unsafeFromGVariant)++foreign import ccall "g_variant_new_tuple" g_variant_new_tuple+        :: Ptr (Ptr GVariant) -> #{type gsize} -> IO (Ptr GVariant)++-- | Given a list of 'GVariant', construct a 'GVariant' tuple+-- containing the elements in the list.+gvariantFromTuple :: [GVariant] -> IO GVariant+gvariantFromTuple children =+    withManagedPtrList children $ \childrenPtrs -> do+      packed <- packPtrArray childrenPtrs+      result <- g_variant_new_tuple packed (fromIntegral $ length children)+      freeMem packed+      wrapGVariantPtr result++-- | Extract the children of a 'GVariant' tuple into a list.+gvariantToTuple :: GVariant -> IO (Maybe [GVariant])+gvariantToTuple = withExplicitType "r" gvariant_get_children++-- | The empty tuple GVariant, mostly useful for type checking.+instance IsGVariant () where+    toGVariant _ = gvariantFromTuple []+    fromGVariant = withTypeCheck (const $ return ())+    toGVariantFormatString _ = "()"++-- | One element tuples.+instance IsGVariant a => IsGVariant (GVariantSinglet a) where+    toGVariant (GVariantSinglet s) = gvariantFromSinglet s+    fromGVariant = gvariantToSinglet >=> return . (GVariantSinglet <$>)+    toGVariantFormatString _ = "("+                               <> toGVariantFormatString (undefined :: a)+                               <> ")"++gvariantFromSinglet :: IsGVariant a => a -> IO GVariant+gvariantFromSinglet s = do+  sv <- toGVariant s+  gvariantFromTuple [sv]++gvariantToSinglet :: forall a. IsGVariant a => GVariant -> IO (Maybe a)+gvariantToSinglet = withExplicitType fmt+                    (gvariant_get_children+                     >=> return . head+                     >=> unsafeFromGVariant)+    where fmt = toGVariantFormatString (undefined :: GVariantSinglet a)++instance (IsGVariant a, IsGVariant b) => IsGVariant (a,b) where+    toGVariant = gvariantFromTwoTuple+    fromGVariant = gvariantToTwoTuple+    toGVariantFormatString _ = "("+                               <> toGVariantFormatString (undefined :: a)+                               <> toGVariantFormatString (undefined :: b)+                               <> ")"++gvariantFromTwoTuple :: (IsGVariant a, IsGVariant b) =>+                        (a,b) -> IO GVariant+gvariantFromTwoTuple (a, b) = do+  va <- toGVariant a+  vb <- toGVariant b+  gvariantFromTuple [va, vb]++gvariantToTwoTuple :: forall a b. (IsGVariant a, IsGVariant b) =>+                      GVariant -> IO (Maybe (a,b))+gvariantToTwoTuple variant = do+  let expectedType = toGVariantFormatString (undefined :: (a,b))+  maybeChildren <- withExplicitType expectedType gvariant_get_children variant+  if isJust maybeChildren+  then do+    let (Just [a1,a2]) = maybeChildren+    (ma1, ma2) <- (,) <$> fromGVariant a1 <*> fromGVariant a2+    return $ if isJust ma1 && isJust ma2+             then Just (fromJust ma1, fromJust ma2)+             else Nothing+  else return Nothing++instance (IsGVariant a, IsGVariant b, IsGVariant c) => IsGVariant (a,b,c) where+    toGVariant = gvariantFromThreeTuple+    fromGVariant = gvariantToThreeTuple+    toGVariantFormatString _ = "("+                               <> toGVariantFormatString (undefined :: a)+                               <> toGVariantFormatString (undefined :: b)+                               <> toGVariantFormatString (undefined :: c)+                               <> ")"++gvariantFromThreeTuple :: (IsGVariant a, IsGVariant b, IsGVariant c) =>+                        (a,b,c) -> IO GVariant+gvariantFromThreeTuple (a, b, c) = do+  va <- toGVariant a+  vb <- toGVariant b+  vc <- toGVariant c+  gvariantFromTuple [va, vb, vc]++gvariantToThreeTuple :: forall a b c. (IsGVariant a, IsGVariant b,+                                                  IsGVariant c) =>+                      GVariant -> IO (Maybe (a,b,c))+gvariantToThreeTuple variant = do+  let expectedType = toGVariantFormatString (undefined :: (a,b,c))+  maybeChildren <- withExplicitType expectedType gvariant_get_children variant+  if isJust maybeChildren+  then do+    let (Just [a1,a2,a3]) = maybeChildren+    (ma1, ma2, ma3) <- (,,) <$> fromGVariant a1+                            <*> fromGVariant a2+                            <*> fromGVariant a3+    return $ if isJust ma1 && isJust ma2 && isJust ma3+             then Just (fromJust ma1, fromJust ma2, fromJust ma3)+             else Nothing+  else return Nothing++instance (IsGVariant a, IsGVariant b, IsGVariant c, IsGVariant d) =>+    IsGVariant (a,b,c,d) where+    toGVariant = gvariantFromFourTuple+    fromGVariant = gvariantToFourTuple+    toGVariantFormatString _ = "("+                               <> toGVariantFormatString (undefined :: a)+                               <> toGVariantFormatString (undefined :: b)+                               <> toGVariantFormatString (undefined :: c)+                               <> toGVariantFormatString (undefined :: d)+                               <> ")"++gvariantFromFourTuple :: (IsGVariant a, IsGVariant b, IsGVariant c,+                          IsGVariant d) => (a,b,c,d) -> IO GVariant+gvariantFromFourTuple (a, b, c, d) = do+  va <- toGVariant a+  vb <- toGVariant b+  vc <- toGVariant c+  vd <- toGVariant d+  gvariantFromTuple [va, vb, vc, vd]++gvariantToFourTuple :: forall a b c d. (IsGVariant a, IsGVariant b,+                                        IsGVariant c, IsGVariant d) =>+                      GVariant -> IO (Maybe (a,b,c,d))+gvariantToFourTuple variant = do+  let expectedType = toGVariantFormatString (undefined :: (a,b,c,d))+  maybeChildren <- withExplicitType expectedType gvariant_get_children variant+  if isJust maybeChildren+  then do+    let (Just [a1,a2,a3,a4]) = maybeChildren+    (ma1, ma2, ma3,ma4) <- (,,,) <$> fromGVariant a1+                                 <*> fromGVariant a2+                                 <*> fromGVariant a3+                                 <*> fromGVariant a4+    return $ if isJust ma1 && isJust ma2 && isJust ma3 && isJust ma4+             then Just (fromJust ma1, fromJust ma2, fromJust ma3, fromJust ma4)+             else Nothing+  else return Nothing++instance (IsGVariant a, IsGVariant b, IsGVariant c, IsGVariant d, IsGVariant e)+    => IsGVariant (a,b,c,d,e) where+    toGVariant = gvariantFromFiveTuple+    fromGVariant = gvariantToFiveTuple+    toGVariantFormatString _ = "("+                               <> toGVariantFormatString (undefined :: a)+                               <> toGVariantFormatString (undefined :: b)+                               <> toGVariantFormatString (undefined :: c)+                               <> toGVariantFormatString (undefined :: d)+                               <> toGVariantFormatString (undefined :: e)+                               <> ")"++gvariantFromFiveTuple :: (IsGVariant a, IsGVariant b, IsGVariant c,+                          IsGVariant d, IsGVariant e) =>+                         (a,b,c,d,e) -> IO GVariant+gvariantFromFiveTuple (a, b, c, d, e) = do+  va <- toGVariant a+  vb <- toGVariant b+  vc <- toGVariant c+  vd <- toGVariant d+  ve <- toGVariant e+  gvariantFromTuple [va, vb, vc, vd, ve]++gvariantToFiveTuple :: forall a b c d e.+                       (IsGVariant a, IsGVariant b, IsGVariant c,+                        IsGVariant d, IsGVariant e) =>+                      GVariant -> IO (Maybe (a,b,c,d,e))+gvariantToFiveTuple variant = do+  let expectedType = toGVariantFormatString (undefined :: (a,b,c,d,e))+  maybeChildren <- withExplicitType expectedType gvariant_get_children variant+  if isJust maybeChildren+  then do+    let (Just [a1,a2,a3,a4,a5]) = maybeChildren+    (ma1, ma2, ma3, ma4, ma5) <- (,,,,) <$> fromGVariant a1+                                        <*> fromGVariant a2+                                        <*> fromGVariant a3+                                        <*> fromGVariant a4+                                        <*> fromGVariant a5+    return $ if isJust ma1 && isJust ma2 && isJust ma3 &&+                              isJust ma4 && isJust ma5+             then Just (fromJust ma1, fromJust ma2, fromJust ma3,+                        fromJust ma4, fromJust ma5)+             else Nothing+  else return Nothing
+ src/Data/GI/Base/ManagedPtr.hs view
@@ -0,0 +1,245 @@+{-# LANGUAGE FlexibleContexts, ScopedTypeVariables #-}+-- | We wrap most objects in a "managed pointer", which is simply a+-- newtype for a 'ForeignPtr' of the appropriate type:+--+-- > newtype Foo = Foo (ForeignPtr Foo)+--+-- Notice that types of this form are instances of+-- 'ForeignPtrNewtype'. The newtype is useful in order to make the+-- newtype an instance of different typeclasses. The routines in this+-- module deal with the memory management of such managed pointers.++module Data.GI.Base.ManagedPtr+    ( -- * Managed pointers+      withManagedPtr+    , withManagedPtrList+    , unsafeManagedPtrGetPtr+    , unsafeManagedPtrCastPtr+    , touchManagedPtr++    -- * Safe casting+    , castTo+    , unsafeCastTo++    -- * Wrappers+    , newObject+    , wrapObject+    , refObject+    , unrefObject+    , newBoxed+    , wrapBoxed+    , copyBoxed+    , copyBoxedPtr+    , freeBoxed+    , wrapPtr+    , newPtr+    ) where++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative ((<$>))+#endif+import Control.Monad (when, void)++import Data.Coerce (coerce)++import Foreign (finalizerFree, poke)+import Foreign.C (CInt(..))+import Foreign.Ptr (Ptr, FunPtr, castPtr)+import Foreign.ForeignPtr (ForeignPtr, newForeignPtr, newForeignPtrEnv, touchForeignPtr)+import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)++import Data.GI.Base.BasicTypes+import Data.GI.Base.Utils++-- | Perform an IO action on the 'Ptr' inside a managed pointer.+withManagedPtr :: ForeignPtrNewtype a => a -> (Ptr a -> IO c) -> IO c+withManagedPtr managed action = do+  let ptr = unsafeManagedPtrGetPtr managed+  result <- action ptr+  touchManagedPtr managed+  return result++-- | Perform an IO action taking a list of 'Ptr' on a list of managed+-- pointers.+withManagedPtrList :: ForeignPtrNewtype a => [a] -> ([Ptr a] -> IO c) -> IO c+withManagedPtrList managedList action = do+  let ptrs = map unsafeManagedPtrGetPtr managedList+  result <- action ptrs+  mapM_ touchManagedPtr managedList+  return result++-- | Return the 'Ptr' in a given managed pointer. As the name says,+-- this is potentially unsafe: the given 'Ptr' may only be used+-- /before/ a call to 'touchManagedPtr'. This function is of most+-- interest to the autogenerated bindings, for hand-written code+-- 'withManagedPtr' is almost always a better choice.+unsafeManagedPtrGetPtr :: ForeignPtrNewtype a => a -> Ptr a+unsafeManagedPtrGetPtr = unsafeManagedPtrCastPtr++-- | Same as 'unsafeManagedPtrGetPtr', but is polymorphic on the+-- return type.+unsafeManagedPtrCastPtr :: forall a b. ForeignPtrNewtype a => a -> Ptr b+unsafeManagedPtrCastPtr x = let p = coerce x :: ForeignPtr ()+                            in castPtr (unsafeForeignPtrToPtr p)++-- | Ensure that the 'Ptr' in the given managed pointer is still alive+-- (i.e. it has not been garbage collected by the runtime) at the+-- point that this is called.+touchManagedPtr :: forall a. ForeignPtrNewtype a => a -> IO ()+touchManagedPtr x = let p = coerce x :: ForeignPtr ()+                     in touchForeignPtr p++-- Safe casting machinery+foreign import ccall unsafe "check_object_type"+    c_check_object_type :: Ptr o -> CGType -> CInt++-- | Cast to the given type, checking that the cast is valid. If it is+-- not, we return `Nothing`. Usage:+--+-- > maybeWidget <- castTo Widget label+castTo :: forall o o'. (GObject o, GObject o') =>+          (ForeignPtr o' -> o') -> o -> IO (Maybe o')+castTo constructor obj =+    withManagedPtr obj $ \objPtr -> do+      GType t <- gobjectType (undefined :: o')+      if c_check_object_type objPtr t /= 1+        then return Nothing+        else Just <$> newObject constructor objPtr++-- | Cast to the given type, assuming that the cast will succeed. This+-- function will call `error` if the cast is illegal.+unsafeCastTo :: forall o o'. (GObject o, GObject o') =>+                (ForeignPtr o' -> o') -> o -> IO o'+unsafeCastTo constructor obj =+  withManagedPtr obj $ \objPtr -> do+    GType t <- gobjectType (undefined :: o')+    if c_check_object_type objPtr t /= 1+      then do+      srcType <- gobjectType obj >>= gtypeName+      destType <- gobjectType (undefined :: o') >>= gtypeName+      error $ "unsafeCastTo :: invalid conversion from " ++ srcType ++ " to "+        ++ destType ++ " requested."+      else newObject constructor objPtr++-- Reference counting for constructors+foreign import ccall "&dbg_g_object_unref"+    ptr_to_g_object_unref :: FunPtr (Ptr a -> IO ())++foreign import ccall "g_object_ref" g_object_ref ::+    Ptr a -> IO (Ptr a)++-- | Construct a Haskell wrapper for a 'GObject', increasing its+-- reference count.+newObject :: (GObject a, GObject b) => (ForeignPtr a -> a) -> Ptr b -> IO a+newObject constructor ptr = do+  void $ g_object_ref ptr+  fPtr <- newForeignPtr ptr_to_g_object_unref $ castPtr ptr+  return $! constructor fPtr++foreign import ccall "g_object_ref_sink" g_object_ref_sink ::+    Ptr a -> IO (Ptr a)++-- | Same as 'newObject', but we take ownership of the object. Newly+-- created 'GObject's are typically floating, so we use+-- <https://developer.gnome.org/gobject/stable/gobject-The-Base-Object-Type.html#g-object-ref-sink g_object_ref_sink>.++-- Notice that the+-- semantics here are a little bit subtle: some objects (such as+-- GtkWindow, see the code about "user_ref_count" in gtkwindow.c in+-- the gtk+ distribution) are created /without/ the floating flag,+-- since they own a reference to themselves. So, wrapping them is+-- really about adding a ref. If we add the ref, when Haskell drops+-- the last ref to the 'GObject' it will /g_object_unref/, and the+-- window will /g_object_unref/ itself upon destruction, so by the end+-- we don't leak memory. If we don't add the ref, there will be two+-- /g_object_unrefs/ acting on the object (one from Haskell and one from+-- the GtkWindow destroy) when the object is destroyed and the second+-- one will give a segfault.+--+-- This is the story for GInitiallyUnowned objects (e.g. anything that+-- is a descendant from GtkWidget). For objects that are not initially+-- floating (i.e. not descendents of GInitiallyUnowned) we simply take+-- control of the reference.+wrapObject :: forall a b. (GObject a, GObject b) =>+              (ForeignPtr a -> a) -> Ptr b -> IO a+wrapObject constructor ptr = do+  when (gobjectIsInitiallyUnowned (undefined :: a)) $+       void $ g_object_ref_sink ptr+  fPtr <- newForeignPtr ptr_to_g_object_unref $ castPtr ptr+  return $! constructor fPtr++-- | Increase the reference count of the given 'GObject'.+refObject :: (GObject a, GObject b) => a -> IO (Ptr b)+refObject obj = castPtr <$> withManagedPtr obj g_object_ref++foreign import ccall "g_object_unref" g_object_unref ::+    Ptr a -> IO ()++-- | Decrease the reference count of the given 'GObject'. The memory+-- associated with the object may be released if the reference count+-- reaches 0.+unrefObject :: GObject a => a -> IO ()+unrefObject obj = withManagedPtr obj g_object_unref++foreign import ccall "& boxed_free_helper" boxed_free_helper ::+    FunPtr (Ptr env -> Ptr a -> IO ())++foreign import ccall "g_boxed_copy" g_boxed_copy ::+    CGType -> Ptr a -> IO (Ptr a)++-- | Construct a Haskell wrapper for the given boxed object. We make a+-- copy of the object.+newBoxed :: forall a. BoxedObject a => (ForeignPtr a -> a) -> Ptr a -> IO a+newBoxed constructor ptr = do+  GType gtype <- boxedType (undefined :: a)+  env <- allocMem :: IO (Ptr CGType)   -- Will be freed by boxed_free_helper+  poke env gtype+  ptr' <- g_boxed_copy gtype ptr+  fPtr <- newForeignPtrEnv boxed_free_helper env ptr'+  return $! constructor fPtr++-- | Like 'newBoxed', but we do not make a copy (we "steal" the passed+-- object, so now it is managed by the Haskell runtime).+wrapBoxed :: forall a. BoxedObject a => (ForeignPtr a -> a) -> Ptr a -> IO a+wrapBoxed constructor ptr = do+  GType gtype <- boxedType (undefined :: a)+  env <- allocMem :: IO (Ptr CGType)   -- Will be freed by boxed_free_helper+  poke env gtype+  fPtr <- newForeignPtrEnv boxed_free_helper env ptr+  return $! constructor fPtr++-- | Make a copy of the given boxed object.+copyBoxed :: forall a. BoxedObject a => a -> IO (Ptr a)+copyBoxed boxed = withManagedPtr boxed copyBoxedPtr++-- | Like 'copyBoxed', but acting directly on a pointer, instead of a+-- managed pointer.+copyBoxedPtr :: forall a. BoxedObject a => Ptr a -> IO (Ptr a)+copyBoxedPtr ptr = do+  GType gtype <- boxedType (undefined :: a)+  g_boxed_copy gtype ptr++foreign import ccall "g_boxed_free" g_boxed_free ::+    CGType -> Ptr a -> IO ()++-- | Free the memory associated with a boxed object+freeBoxed :: forall a. BoxedObject a => a -> IO ()+freeBoxed boxed = do+  GType gtype <- boxedType (undefined :: a)+  let ptr = unsafeManagedPtrGetPtr boxed+  g_boxed_free gtype ptr+  touchManagedPtr boxed++-- | Wrap a pointer, taking ownership of it.+wrapPtr :: (ForeignPtr a -> a) -> Ptr a -> IO a+wrapPtr constructor ptr = do+  fPtr <- newForeignPtr finalizerFree ptr+  return $! constructor fPtr++-- | Wrap a pointer to n bytes, making a copy of the data.+newPtr :: Int -> (ForeignPtr a -> a) -> Ptr a -> IO a+newPtr n constructor ptr = do+  ptr' <- callocBytes n :: IO (Ptr a)+  memcpy ptr' ptr n+  fPtr <- newForeignPtr finalizerFree ptr'+  return $! constructor fPtr
+ src/Data/GI/Base/Overloading.hs view
@@ -0,0 +1,128 @@+{-# LANGUAGE TypeOperators, KindSignatures, DataKinds, PolyKinds,+             TypeFamilies, UndecidableInstances, EmptyDataDecls,+             MultiParamTypeClasses, FlexibleInstances, ConstraintKinds #-}++-- | Helpers for dealing with `GObject`s.++module Data.GI.Base.Overloading+    ( -- * Type level inheritance+      ParentTypes+    , IsDescendantOf++    -- * Looking up attributes in parent types+    , AttributeList+    , ResolveAttribute+    , HasAttribute+    , HasAttr++    -- * Looking up signals in parent types+    , SignalList+    , ResolveSignal+    , HasSignal+    ) where++import GHC.Exts (Constraint)+import GHC.TypeLits++-- | Join two lists.+type family JoinLists (as :: [a]) (bs :: [a]) :: [a] where+    JoinLists '[] bs = bs+    JoinLists (a ': as) bs = a ': JoinLists as bs++-- | Look in the given list of (symbol, tag) tuples for the tag+-- corresponding to the given symbol. If not found return the given+-- default type.+type family FindElement (m :: Symbol) (ms :: [(Symbol, *)]) (d :: *) :: * where+    FindElement m '[] d = d+    FindElement m ('(m, o) ': ms) d = o+    FindElement m ('(m', o) ': ms) d = FindElement m ms d++-- | Result of a ancestor check. Basically a Bool type with a bit of+-- extra info in order to improve typechecker error messages.+data AncestorCheck t a = HasAncestor a t | DoesNotHaveRequiredAncestor Symbol t Symbol a++-- | Check whether a type appears in a list. We specialize the+-- names/types a bit so the error messages are more informative.+type family CheckForAncestorType t (a :: *) (as :: [*]) :: AncestorCheck * * where+    CheckForAncestorType t a '[] =+        'DoesNotHaveRequiredAncestor "Error: Required ancestor" a "not found for type" t+    CheckForAncestorType t a (a ': as) = 'HasAncestor a t+    CheckForAncestorType t a (b ': as) = CheckForAncestorType t a as++-- | Check that a type is in the list of `GObjectParents` of another+-- `GObject`-derived type.+type family IsDescendantOf (parent :: *) (descendant :: *) :: Constraint where+    -- Every object is defined to be a descendant of itself.+    IsDescendantOf d d = () ~ ()+    IsDescendantOf p d = CheckForAncestorType d p (ParentTypes d) ~ 'HasAncestor p d++-- | The direct parents of this object: its direct parent type, if any,+-- and the interfaces it implements. The interfaces inherited from+-- parent types can be omitted.+type family ParentTypes a :: [*]++-- | The list of attributes defined for a given type. Each element of+-- the list is a tuple, with the first element of the tuple the name+-- of the attribute, and the second the type encoding the information+-- of the attribute. This type will be an instance of `AttrInfo`.+type family AttributeList a :: [(Symbol, *)]++-- | Datatype returned when the attribute is not found, hopefully making+-- the resulting error messages somewhat clearer.+data UnknownAttribute (msg1 :: Symbol) (s :: Symbol) (msg2 :: Symbol) (o :: *)++-- | Return the type encoding the attribute information for a given+-- type and attribute.+type family ResolveAttribute (s :: Symbol) (o :: *) :: * where+    ResolveAttribute s o = FindElement s (AttributeList o)+                           (UnknownAttribute "Error: could not find attribute" s "for object" o)++-- | Whether a given type is in the given list. If found, return+-- @success@, otherwise return @failure@.+type family IsElem (e :: Symbol) (es :: [(Symbol, *)]) (success :: k) (failure :: k) :: k where+    IsElem e '[] success failure = failure+    IsElem e ( '(e, t) ': es) success failure = success+    IsElem e ( '(other, t) ': es) s f = IsElem e es s f++-- | Isomorphic to Bool, but having some extra debug information.+data AttributeCheck a t = HasAttribute+                        | DoesNotHaveAttribute Symbol a Symbol t++-- | A constraint imposing that the given object has the given attribute.+type family HasAttribute (attr :: Symbol) (o :: *) where+    HasAttribute attr o = IsElem attr (AttributeList o)+                          'HasAttribute+                          ('DoesNotHaveAttribute "Error: attribute" attr "not found for type" o)+                          ~ 'HasAttribute++-- | A constraint that enforces that the given type has a given attribute.+class HasAttr (attr :: Symbol) (o :: *)+instance HasAttribute attr o => HasAttr attr o++-- | The list of signals defined for a given type. Each element of+-- the list is a tuple, with the first element of the tuple the name+-- of the signal, and the second the type encoding the information of+-- the signal. This type will be an instance of `SignalInfo`.+type family SignalList a :: [(Symbol, *)]++-- | Datatype returned when the signal is not found, hopefully making+-- the resulting error messages somewhat clearer.+data UnknownSignal (msg1 :: Symbol) (s :: Symbol) (msg2 :: Symbol) (o :: *)++-- | Return the type encoding the signal information for a given+-- type and signal.+type family ResolveSignal (s :: Symbol) (o :: *) :: * where+    ResolveSignal s o = FindElement s (SignalList o)+                        (UnknownSignal "Error: could not find signal" s "for object" o)++-- | Isomorphic to Bool, but having some extra debug information.+data SignalCheck s t = HasSignal+                     | DoesNotHaveSignal Symbol s Symbol t++-- | A constraint enforcing that the signal exists for the given+-- object, or one of its ancestors.+type family HasSignal (s :: Symbol) (o :: *) where+    HasSignal s o = IsElem s (SignalList o)+                    'HasSignal+                    ('DoesNotHaveSignal "Error: signal" s "not found for type" o)+                    ~ 'HasSignal
+ src/Data/GI/Base/Properties.hsc view
@@ -0,0 +1,553 @@+{-# LANGUAGE ScopedTypeVariables, GADTs, DataKinds, KindSignatures,+FlexibleInstances, MultiParamTypeClasses, TypeFamilies, PolyKinds,+EmptyDataDecls, ConstraintKinds #-}+{-# OPTIONS_GHC -Wall -fno-warn-orphans #-}++module Data.GI.Base.Properties+    ( new++    , PropertyNotify(..)+    , GObjectNotifySignalInfo++    , setObjectPropertyString+    , setObjectPropertyStringArray+    , setObjectPropertyPtr+    , setObjectPropertyCInt+    , setObjectPropertyCUInt+    , setObjectPropertyInt64+    , setObjectPropertyUInt64+    , setObjectPropertyFloat+    , setObjectPropertyDouble+    , setObjectPropertyBool+    , setObjectPropertyGType+    , setObjectPropertyObject+    , setObjectPropertyBoxed+    , setObjectPropertyEnum+    , setObjectPropertyFlags+    , setObjectPropertyVariant+    , setObjectPropertyByteArray+    , setObjectPropertyPtrGList+    , setObjectPropertyHash++    , getObjectPropertyString+    , getObjectPropertyStringArray+    , getObjectPropertyPtr+    , getObjectPropertyCInt+    , getObjectPropertyCUInt+    , getObjectPropertyInt64+    , getObjectPropertyUInt64+    , getObjectPropertyFloat+    , getObjectPropertyDouble+    , getObjectPropertyBool+    , getObjectPropertyGType+    , getObjectPropertyObject+    , getObjectPropertyBoxed+    , getObjectPropertyEnum+    , getObjectPropertyFlags+    , getObjectPropertyVariant+    , getObjectPropertyByteArray+    , getObjectPropertyPtrGList+    , getObjectPropertyHash++    , constructObjectPropertyString+    , constructObjectPropertyStringArray+    , constructObjectPropertyPtr+    , constructObjectPropertyCInt+    , constructObjectPropertyCUInt+    , constructObjectPropertyInt64+    , constructObjectPropertyUInt64+    , constructObjectPropertyFloat+    , constructObjectPropertyDouble+    , constructObjectPropertyBool+    , constructObjectPropertyGType+    , constructObjectPropertyObject+    , constructObjectPropertyBoxed+    , constructObjectPropertyEnum+    , constructObjectPropertyFlags+    , constructObjectPropertyVariant+    , constructObjectPropertyByteArray+    , constructObjectPropertyPtrGList+    , constructObjectPropertyHash+    ) where++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative ((<$>))+#endif+import Control.Monad ((>=>))++import qualified Data.ByteString.Char8 as B+import Data.Text (Text)+import Data.Proxy (Proxy(..))++import Data.GI.Base.BasicTypes+import Data.GI.Base.BasicConversions+import Data.GI.Base.ManagedPtr+import Data.GI.Base.Attributes+import Data.GI.Base.GParamSpec (newGParamSpecFromPtr)+import Data.GI.Base.GValue+import Data.GI.Base.GVariant (newGVariantFromPtr)+import Data.GI.Base.Overloading (ResolveAttribute, HasAttr)+import Data.GI.Base.Signals (SignalConnectMode, SignalHandlerId,+                         connectSignalFunPtr,+                         SignalInfo(HaskellCallbackType, connectSignal))++import GHC.Exts (Constraint)+import GHC.TypeLits++import Foreign hiding (new)+import Foreign.C++#include <glib-object.h>++foreign import ccall "dbg_g_object_newv" g_object_newv ::+    GType -> CUInt -> Ptr a -> IO (Ptr b)++-- | Construct a GObject given the constructor and a list of settable+-- attributes. AttrOps are always constructible, so we don't need to+-- enforce constraints here.+new :: forall o. GObject o => (ForeignPtr o -> o) ->+       [AttrOp o 'AttrConstruct] -> IO o+new constructor attrs = do+  props <- mapM construct attrs+  let nprops = length props+  params <- mallocBytes (nprops*gparameterSize)+  fill params props+  gtype <- gobjectType (undefined :: o)+  result <- g_object_newv gtype (fromIntegral nprops) params+  freeStrings nprops params+  free params+  -- Make sure that the GValues defining the GProperties are still+  -- alive at this point (so, in particular, they are still alive when+  -- g_object_newv is called). Without this the GHC garbage collector+  -- may free the GValues before g_object_newv us called, which will+  -- unref the referred to objects, which may drop the last reference+  -- to the contained objects. g_object_newv then tries to access the+  -- (now invalid) contents of the GValue, and mayhem ensues.+  mapM_ (touchManagedPtr . snd) props+  wrapObject constructor (result :: Ptr o)+  where+    resolve :: proxy attr -> Proxy (ResolveAttribute attr o)+    resolve _ = Proxy++    construct :: AttrOp o 'AttrConstruct ->+                 IO (String, GValue)+    construct (attr := x) = attrConstruct (resolve attr) x+    construct (attr :=> x) = x >>= attrConstruct (resolve attr)++    gvalueSize = #size GValue+    gparameterSize = #size GParameter++    -- Fill the given memory address with the contents of the array of+    -- GParameters.+    fill :: Ptr () -> [(String, GValue)] -> IO ()+    fill _ [] = return ()+    fill dataPtr ((str, gvalue):xs) =+        do cstr <- newCString str+           poke (castPtr dataPtr) cstr+           withManagedPtr gvalue $ \gvalueptr ->+               copyBytes (dataPtr `plusPtr` sizeOf nullPtr) gvalueptr gvalueSize+           fill (dataPtr `plusPtr` gparameterSize) xs++    -- Free the strings in the GParameter array (the GValues will be+    -- freed separately).+    freeStrings :: Int -> Ptr () -> IO ()+    freeStrings 0 _ = return ()+    freeStrings n dataPtr =+        do cstr <- peek (castPtr dataPtr) :: IO CString+           free cstr+           freeStrings (n-1) (dataPtr `plusPtr` gparameterSize)++-- | Proxy for "notify::property-name" signals.+data PropertyNotify (s :: Symbol) (propName :: Symbol) (constraint :: * -> Constraint) where+  PropertyNotify :: KnownSymbol propName => proxy propName ->+                    PropertyNotify "notify::[property]" propName (HasAttr propName)++-- | Connection information for a "notify" signal indicating that a+-- specific property changed (see `PropertyNotify` for the relevant+-- constructor).+data GObjectNotifySignalInfo+instance SignalInfo GObjectNotifySignalInfo where+  type HaskellCallbackType GObjectNotifySignalInfo = GObjectNotifyCallback+  connectSignal = connectGObjectNotify++-- | Type for a `GObject` `notify` callback.+type GObjectNotifyCallback = GParamSpec -> IO ()++gobjectNotifyCallbackWrapper ::+    GObjectNotifyCallback -> Ptr () -> Ptr GParamSpec -> Ptr () -> IO ()+gobjectNotifyCallbackWrapper _cb _ pspec _ = do+    pspec' <- newGParamSpecFromPtr pspec+    _cb  pspec'++type GObjectNotifyCallbackC = Ptr () -> Ptr GParamSpec -> Ptr () -> IO ()++foreign import ccall "wrapper"+    mkGObjectNotifyCallback :: GObjectNotifyCallbackC -> IO (FunPtr GObjectNotifyCallbackC)++-- | Connect the given notify callback for a GObject.+connectGObjectNotify :: forall o i proxy propName constraint.+                        (GObject o, constraint o, KnownSymbol propName) =>+                        proxy (i :: *) (propName :: Symbol) (constraint :: * -> Constraint) ->+                        o -> GObjectNotifyCallback ->+                        SignalConnectMode -> IO SignalHandlerId+connectGObjectNotify _ obj cb after = do+  cb' <- mkGObjectNotifyCallback (gobjectNotifyCallbackWrapper cb)+  let signalName = "notify::" ++ symbolVal (Proxy :: Proxy propName)+  connectSignalFunPtr obj signalName cb' after++foreign import ccall "g_object_set_property" g_object_set_property ::+    Ptr a -> CString -> Ptr GValue -> IO ()++setObjectProperty :: GObject a => a -> String -> b ->+                     (GValue -> b -> IO ()) -> GType -> IO ()+setObjectProperty obj propName propValue setter (GType gtype) = do+  gvalue <- buildGValue (GType gtype) setter propValue+  withManagedPtr obj $ \objPtr ->+      withCString propName $ \cPropName ->+          withManagedPtr gvalue $ \gvalueptr ->+              g_object_set_property objPtr cPropName gvalueptr++foreign import ccall "g_object_get_property" g_object_get_property ::+    Ptr a -> CString -> Ptr GValue -> IO ()++getObjectProperty :: GObject a => a -> String ->+                     (GValue -> IO b) -> GType -> IO b+getObjectProperty obj propName getter gtype = do+  gvalue <- newGValue gtype+  withManagedPtr obj $ \objPtr ->+      withCString propName $ \cPropName ->+          withManagedPtr gvalue $ \gvalueptr ->+              g_object_get_property objPtr cPropName gvalueptr+  getter gvalue++constructObjectProperty :: String -> b -> (GValue -> b -> IO ()) ->+                           GType -> IO (String, GValue)+constructObjectProperty propName propValue setter gtype = do+  gvalue <- buildGValue gtype setter propValue+  return (propName, gvalue)++setObjectPropertyString :: GObject a =>+                           a -> String -> Text -> IO ()+setObjectPropertyString obj propName str =+    setObjectProperty obj propName str set_string (GType #const G_TYPE_STRING)++constructObjectPropertyString :: String -> Text ->+                                 IO (String, GValue)+constructObjectPropertyString propName str =+    constructObjectProperty propName str set_string (GType #const G_TYPE_STRING)++getObjectPropertyString :: GObject a =>+                           a -> String -> IO Text+getObjectPropertyString obj propName =+    getObjectProperty obj propName get_string (GType #const G_TYPE_STRING)++setObjectPropertyPtr :: GObject a =>+                        a -> String -> Ptr b -> IO ()+setObjectPropertyPtr obj propName ptr =+    setObjectProperty obj propName ptr set_pointer (GType #const G_TYPE_POINTER)++constructObjectPropertyPtr :: String -> Ptr b ->+                              IO (String, GValue)+constructObjectPropertyPtr propName ptr =+    constructObjectProperty propName ptr set_pointer (GType #const G_TYPE_POINTER)++getObjectPropertyPtr :: GObject a =>+                        a -> String -> IO (Ptr b)+getObjectPropertyPtr obj propName =+    getObjectProperty obj propName get_pointer (GType #const G_TYPE_POINTER)++setObjectPropertyCInt :: GObject a =>+                         a -> String -> Int32 -> IO ()+setObjectPropertyCInt obj propName int =+    setObjectProperty obj propName int set_int32 (GType #const G_TYPE_INT)++constructObjectPropertyCInt :: String -> Int32 ->+                                IO (String, GValue)+constructObjectPropertyCInt propName int =+    constructObjectProperty propName int set_int32 (GType #const G_TYPE_INT)++getObjectPropertyCInt :: GObject a => a -> String -> IO Int32+getObjectPropertyCInt obj propName =+    getObjectProperty obj propName get_int32 (GType #const G_TYPE_INT)++setObjectPropertyCUInt :: GObject a =>+                          a -> String -> Word32 -> IO ()+setObjectPropertyCUInt obj propName uint =+    setObjectProperty obj propName uint set_uint32 (GType #const G_TYPE_UINT)++constructObjectPropertyCUInt :: String -> Word32 ->+                                IO (String, GValue)+constructObjectPropertyCUInt propName uint =+    constructObjectProperty propName uint set_uint32 (GType #const G_TYPE_UINT)++getObjectPropertyCUInt :: GObject a => a -> String -> IO Word32+getObjectPropertyCUInt obj propName =+    getObjectProperty obj propName get_uint32 (GType #const G_TYPE_UINT)++setObjectPropertyInt64 :: GObject a =>+                          a -> String -> Int64 -> IO ()+setObjectPropertyInt64 obj propName int64 =+    setObjectProperty obj propName int64 set_int64 (GType #const G_TYPE_INT64)++constructObjectPropertyInt64 :: String -> Int64 ->+                                IO (String, GValue)+constructObjectPropertyInt64 propName int64 =+    constructObjectProperty propName int64 set_int64 (GType #const G_TYPE_INT64)++getObjectPropertyInt64 :: GObject a => a -> String -> IO Int64+getObjectPropertyInt64 obj propName =+    getObjectProperty obj propName get_int64 (GType #const G_TYPE_INT64)++setObjectPropertyUInt64 :: GObject a =>+                          a -> String -> Word64 -> IO ()+setObjectPropertyUInt64 obj propName uint64 =+    setObjectProperty obj propName uint64 set_uint64 (GType #const G_TYPE_UINT64)++constructObjectPropertyUInt64 :: String -> Word64 ->+                                 IO (String, GValue)+constructObjectPropertyUInt64 propName uint64 =+    constructObjectProperty propName uint64 set_uint64 (GType #const G_TYPE_UINT64)++getObjectPropertyUInt64 :: GObject a => a -> String -> IO Word64+getObjectPropertyUInt64 obj propName =+    getObjectProperty obj propName get_uint64 (GType #const G_TYPE_UINT64)++setObjectPropertyFloat :: GObject a =>+                           a -> String -> Float -> IO ()+setObjectPropertyFloat obj propName float =+    setObjectProperty obj propName float set_float (GType #const G_TYPE_FLOAT)++constructObjectPropertyFloat :: String -> Float ->+                                 IO (String, GValue)+constructObjectPropertyFloat propName float =+    constructObjectProperty propName float set_float (GType #const G_TYPE_FLOAT)++getObjectPropertyFloat :: GObject a =>+                           a -> String -> IO Float+getObjectPropertyFloat obj propName =+    getObjectProperty obj propName get_float (GType #const G_TYPE_FLOAT)++setObjectPropertyDouble :: GObject a =>+                            a -> String -> Double -> IO ()+setObjectPropertyDouble obj propName double =+    setObjectProperty obj propName double set_double (GType #const G_TYPE_DOUBLE)++constructObjectPropertyDouble :: String -> Double ->+                                  IO (String, GValue)+constructObjectPropertyDouble propName double =+    constructObjectProperty propName double set_double (GType #const G_TYPE_DOUBLE)++getObjectPropertyDouble :: GObject a =>+                            a -> String -> IO Double+getObjectPropertyDouble obj propName =+    getObjectProperty obj propName get_double (GType #const G_TYPE_DOUBLE)++setObjectPropertyBool :: GObject a =>+                         a -> String -> Bool -> IO ()+setObjectPropertyBool obj propName bool =+    setObjectProperty obj propName bool set_boolean (GType #const G_TYPE_BOOLEAN)++constructObjectPropertyBool :: String -> Bool -> IO (String, GValue)+constructObjectPropertyBool propName bool =+    constructObjectProperty propName bool set_boolean (GType #const G_TYPE_BOOLEAN)++getObjectPropertyBool :: GObject a => a -> String -> IO Bool+getObjectPropertyBool obj propName =+    getObjectProperty obj propName get_boolean (GType #const G_TYPE_BOOLEAN)++setObjectPropertyGType :: GObject a =>+                         a -> String -> GType -> IO ()+setObjectPropertyGType obj propName gtype =+    setObjectProperty obj propName gtype set_gtype (GType #const G_TYPE_GTYPE)++constructObjectPropertyGType :: String -> GType -> IO (String, GValue)+constructObjectPropertyGType propName bool =+    constructObjectProperty propName bool set_gtype (GType #const G_TYPE_GTYPE)++getObjectPropertyGType :: GObject a => a -> String -> IO GType+getObjectPropertyGType obj propName =+    getObjectProperty obj propName get_gtype (GType #const G_TYPE_GTYPE)++setObjectPropertyObject :: (GObject a, GObject b) =>+                           a -> String -> b -> IO ()+setObjectPropertyObject obj propName object = do+  gtype <- gobjectType object+  withManagedPtr object $ \objectPtr ->+      setObjectProperty obj propName objectPtr set_object gtype++constructObjectPropertyObject :: GObject a =>+                                 String -> a -> IO (String, GValue)+constructObjectPropertyObject propName object = do+  gtype <- gobjectType object+  withManagedPtr object $ \objectPtr ->+      constructObjectProperty propName objectPtr set_object gtype++getObjectPropertyObject :: forall a b. (GObject a, GObject b) =>+                           a -> String -> (ForeignPtr b -> b) -> IO b+getObjectPropertyObject obj propName constructor = do+  gtype <- gobjectType (undefined :: b)+  getObjectProperty obj propName+                        (\val -> (get_object val :: IO (Ptr b))+                                 >>= newObject constructor)+                      gtype++setObjectPropertyBoxed :: (GObject a, BoxedObject b) =>+                          a -> String -> b -> IO ()+setObjectPropertyBoxed obj propName boxed = do+  gtype <- boxedType boxed+  withManagedPtr boxed $ \boxedPtr ->+        setObjectProperty obj propName boxedPtr set_boxed gtype++constructObjectPropertyBoxed :: (BoxedObject a) => String -> a ->+                                IO (String, GValue)+constructObjectPropertyBoxed propName boxed = do+  gtype <- boxedType boxed+  withManagedPtr boxed $ \boxedPtr ->+      constructObjectProperty propName boxedPtr set_boxed gtype++getObjectPropertyBoxed :: forall a b. (GObject a, BoxedObject b) =>+                          a -> String -> (ForeignPtr b -> b) -> IO b+getObjectPropertyBoxed obj propName constructor = do+  gtype <- boxedType (undefined :: b)+  getObjectProperty obj propName (get_boxed >=> newBoxed constructor) gtype++setObjectPropertyStringArray :: GObject a =>+                                a -> String -> [Text] -> IO ()+setObjectPropertyStringArray obj propName strv = do+  cStrv <- packZeroTerminatedUTF8CArray strv+  setObjectProperty obj propName cStrv set_boxed (GType #const G_TYPE_STRV)+  mapZeroTerminatedCArray free cStrv+  free cStrv++constructObjectPropertyStringArray :: String -> [Text] ->+                                      IO (String, GValue)+constructObjectPropertyStringArray propName strv = do+  cStrv <- packZeroTerminatedUTF8CArray strv+  result <- constructObjectProperty propName cStrv set_boxed (GType #const G_TYPE_STRV)+  mapZeroTerminatedCArray free cStrv+  free cStrv+  return result++getObjectPropertyStringArray :: GObject a =>+                                a -> String -> IO [Text]+getObjectPropertyStringArray obj propName =+    getObjectProperty obj propName+                      (get_boxed >=> unpackZeroTerminatedUTF8CArray . castPtr)+                      (GType #const G_TYPE_STRV)++setObjectPropertyEnum :: (GObject a, Enum b, BoxedEnum b) =>+                         a -> String -> b -> IO ()+setObjectPropertyEnum obj propName enum = do+  gtype <- boxedEnumType enum+  let cEnum = (fromIntegral . fromEnum) enum+  setObjectProperty obj propName cEnum set_enum gtype++constructObjectPropertyEnum :: (Enum a, BoxedEnum a) =>+                               String -> a -> IO (String, GValue)+constructObjectPropertyEnum propName enum = do+  gtype <- boxedEnumType enum+  let cEnum = (fromIntegral . fromEnum) enum+  constructObjectProperty propName cEnum set_enum gtype++getObjectPropertyEnum :: forall a b. (GObject a,+                                      Enum b, BoxedEnum b) =>+                         a -> String -> IO b+getObjectPropertyEnum obj propName = do+  gtype <- boxedEnumType (undefined :: b)+  getObjectProperty obj propName+                    (\val -> toEnum . fromIntegral <$> get_enum val)+                    gtype++setObjectPropertyFlags :: (IsGFlag b, GObject a) =>+                          a -> String -> [b] -> IO ()+setObjectPropertyFlags obj propName flags =+    let cFlags = gflagsToWord flags+    in setObjectProperty obj propName cFlags set_flags (GType #const G_TYPE_FLAGS)++constructObjectPropertyFlags :: IsGFlag a => String -> [a] ->+                                IO (String, GValue)+constructObjectPropertyFlags propName flags =+    let cFlags = gflagsToWord flags+    in constructObjectProperty propName cFlags set_flags (GType #const G_TYPE_FLAGS)++getObjectPropertyFlags :: (GObject a, IsGFlag b) =>+                          a -> String -> IO [b]+getObjectPropertyFlags obj propName =+    getObjectProperty obj propName+                          (\val -> wordToGFlags <$> get_flags val)+                          (GType #const G_TYPE_FLAGS)++setObjectPropertyVariant :: GObject a =>+                            a -> String -> GVariant -> IO ()+setObjectPropertyVariant obj propName variant =+    withManagedPtr variant $ \variantPtr ->+        setObjectProperty obj propName variantPtr set_variant+                              (GType #const G_TYPE_VARIANT)++constructObjectPropertyVariant :: String -> GVariant -> IO (String, GValue)+constructObjectPropertyVariant propName obj =+    withManagedPtr obj $ \objPtr ->+        constructObjectProperty propName objPtr set_variant+                                    (GType #const G_TYPE_VARIANT)++getObjectPropertyVariant :: GObject a => a -> String ->+                            IO GVariant+getObjectPropertyVariant obj propName =+    getObjectProperty obj propName (get_variant >=> newGVariantFromPtr)+                      (GType #const G_TYPE_VARIANT)++setObjectPropertyByteArray :: GObject a =>+                              a -> String -> B.ByteString -> IO ()+setObjectPropertyByteArray obj propName bytes = do+  packed <- packGByteArray bytes+  setObjectProperty obj propName packed set_boxed (GType #const G_TYPE_BYTE_ARRAY)+  unrefGByteArray packed++constructObjectPropertyByteArray :: String -> B.ByteString ->+                                    IO (String, GValue)+constructObjectPropertyByteArray propName bytes = do+  packed <- packGByteArray bytes+  result <- constructObjectProperty propName packed+            set_boxed (GType #const G_TYPE_BYTE_ARRAY)+  unrefGByteArray packed+  return result++getObjectPropertyByteArray :: GObject a =>+                              a -> String -> IO B.ByteString+getObjectPropertyByteArray obj propName =+    getObjectProperty obj propName (get_boxed >=> unpackGByteArray)+                      (GType #const G_TYPE_BYTE_ARRAY)++setObjectPropertyPtrGList :: GObject a =>+                              a -> String -> [Ptr b] -> IO ()+setObjectPropertyPtrGList obj propName ptrs = do+  packed <- packGList ptrs+  setObjectProperty obj propName packed set_boxed (GType #const G_TYPE_POINTER)+  g_list_free packed++constructObjectPropertyPtrGList :: String -> [Ptr a] ->+                                    IO (String, GValue)+constructObjectPropertyPtrGList propName ptrs = do+  packed <- packGList ptrs+  result <- constructObjectProperty propName packed+            set_boxed (GType #const G_TYPE_POINTER)+  g_list_free packed+  return result++getObjectPropertyPtrGList :: GObject a =>+                              a -> String -> IO [Ptr b]+getObjectPropertyPtrGList obj propName =+    getObjectProperty obj propName (get_pointer >=> unpackGList)+                      (GType #const G_TYPE_POINTER)++setObjectPropertyHash :: GObject a => a -> String -> b -> IO ()+setObjectPropertyHash =+    error $ "Setting GHashTable properties not supported yet."++constructObjectPropertyHash :: String -> b -> IO (String, GValue)+constructObjectPropertyHash =+    error $ "Constructing GHashTable properties not supported yet."++getObjectPropertyHash :: GObject a => a -> String -> IO b+getObjectPropertyHash =+    error $ "Getting GHashTable properties not supported yet."
+ src/Data/GI/Base/ShortPrelude.hs view
@@ -0,0 +1,30 @@+-- | The Haskell Prelude exports a number of symbols that can easily+-- collide with functions appearing in bindings. The generated code+-- requires just a small subset of the functions in the Prelude, which+-- we reexport explicitly here.+module Data.GI.Base.ShortPrelude+    ( Enum(fromEnum, toEnum)+    , Show(..)+    , Eq(..)+    , IO+    , Monad(..)+    , Maybe(..)+    , (.)+    , ($)+    , (++)+    , (=<<)+    , Bool(..)+    , Float+    , Double+    , undefined+    , error+    , map+    , length+    , mapM+    , mapM_+    , when+    , fromIntegral+    , realToFrac+    ) where++import Control.Monad (when)
+ src/Data/GI/Base/Signals.hsc view
@@ -0,0 +1,105 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE FlexibleInstances #-}++-- | Routines for connecting `GObject`s to signals.+module Data.GI.Base.Signals+    ( SignalConnectMode(..),+      connectSignalFunPtr,+      on,+      after,+      SignalHandlerId,+      SignalInfo(..)+    ) where++import Foreign+import Foreign.C++import GHC.Exts (Constraint)+import GHC.TypeLits++import Data.GI.Base.BasicTypes+import Data.GI.Base.ManagedPtr (withManagedPtr)+import Data.GI.Base.Overloading (HasSignal, ResolveSignal)+import Data.GI.Base.Utils (safeFreeFunPtrPtr)++#include <glib-object.h>++-- | Type of a `GObject` signal handler id.+type SignalHandlerId = #type gulong++-- | A proxy for passing on the signal information.+data SignalProxy (s :: *) (e :: Symbol) (c :: * -> Constraint) = SignalProxy++-- | Information about an overloaded signal.+class SignalInfo (info :: *) where+    type HaskellCallbackType info+    -- | Connect a Haskell function to a signal of the given `GObject`,+    -- specifying whether the handler will be called before or after+    -- the default handler.+    connectSignal :: (KnownSymbol extra, GObject o, constraint o) =>+                     SignalProxy info extra constraint ->+                     o ->+                     HaskellCallbackType info ->+                     SignalConnectMode ->+                     IO SignalHandlerId++-- | Whether to connect a handler to a signal with `connectSignal` so+-- that it runs before/after the default handler for the given signal.+data SignalConnectMode = SignalConnectBefore  -- ^ Run before the default handler.+        | SignalConnectAfter -- ^ Run after the default handler.++-- | Same as `connectSignal`, specifying from the beginning that the+-- handler is to be run before the default handler.+--+-- > on = connectSignal SignalConnectBefore+on :: forall signal extra o info constraint proxy.+      (GObject o,+       HasSignal signal o, info ~ ResolveSignal signal o, SignalInfo info,+       KnownSymbol extra, constraint o) =>+      o -> proxy (signal :: Symbol) (extra :: Symbol) (constraint :: * -> Constraint)+        -> HaskellCallbackType info -> IO SignalHandlerId+on o p c = connectSignal (resolve p) o c SignalConnectBefore+    where resolve :: proxy signal extra constraint ->+                     SignalProxy (ResolveSignal signal o) extra constraint+          resolve _ = SignalProxy++-- | Connect a signal to a handler, running the handler after the default one.+--+-- > after = connectSignal SignalConnectAfter+after :: forall signal extra o info constraint proxy.+         (GObject o,+          HasSignal signal o, info ~ ResolveSignal signal o, SignalInfo info,+          KnownSymbol extra, constraint o) =>+         o -> proxy (signal :: Symbol) (extra :: Symbol) (constraint :: * -> Constraint)+           -> HaskellCallbackType info -> IO SignalHandlerId+after o p c = connectSignal (resolve p) o c SignalConnectAfter+    where resolve :: proxy signal extra constraint ->+                     SignalProxy (ResolveSignal signal o) extra constraint+          resolve _ = SignalProxy++-- Connecting GObjects to signals+foreign import ccall "g_signal_connect_data" g_signal_connect_data ::+    Ptr a ->                            -- instance+    CString ->                          -- detailed_signal+    FunPtr b ->                         -- c_handler+    Ptr () ->                           -- data+    FunPtr c ->                         -- destroy_data+    CUInt ->                            -- connect_flags+    IO SignalHandlerId++-- | Connect a signal to a handler, given as a `FunPtr`.+connectSignalFunPtr :: GObject o =>+                  o -> String -> FunPtr a -> SignalConnectMode -> IO SignalHandlerId+connectSignalFunPtr object signal fn mode = do+  let flags = case mode of+                SignalConnectAfter -> 1+                SignalConnectBefore -> 0+  withCString signal $ \csignal ->+    withManagedPtr object $ \objPtr ->+        g_signal_connect_data objPtr csignal fn (castFunPtrToPtr fn) safeFreeFunPtrPtr flags
+ src/Data/GI/Base/Utils.hsc view
@@ -0,0 +1,156 @@+{-# LANGUAGE ScopedTypeVariables, TupleSections #-}+{- | Assorted utility functions for bindings. -}+module Data.GI.Base.Utils+    ( whenJust+    , maybeM+    , maybeFromPtr+    , mapFirst+    , mapFirstA+    , mapSecond+    , mapSecondA+    , convertIfNonNull+    , callocBytes+    , callocBoxedBytes+    , allocBytes+    , allocMem+    , freeMem+    , ptr_to_g_free+    , memcpy+    , safeFreeFunPtr+    , safeFreeFunPtrPtr+    , maybeReleaseFunPtr+    ) where++#include <glib-object.h>++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative (Applicative, pure, (<$>), (<*>))+#endif+import Control.Monad (void)++import Data.Word++import Foreign (peek)+import Foreign.C.Types (CSize(..))+import Foreign.Ptr (Ptr, nullPtr, FunPtr, freeHaskellFunPtr)+import Foreign.Storable (Storable(..))++import Data.GI.Base.BasicTypes (GType(..), CGType, BoxedObject(..))++-- | When the given value is of "Just a" form, execute the given action,+-- otherwise do nothing.+whenJust :: Monad m => Maybe a -> (a -> m ()) -> m ()+whenJust (Just v) f = f v+whenJust Nothing _ = return ()++-- | Like `Control.Monad.maybe`, but for actions on a monad, and with+-- slightly different argument order.+maybeM :: Monad m => b -> Maybe a -> (a -> m b) -> m b+maybeM d Nothing _ = return d+maybeM _ (Just v) action = action v++-- | Check if the pointer is `nullPtr`, and wrap it on a `Maybe`+-- accordingly.+maybeFromPtr :: Ptr a -> Maybe (Ptr a)+maybeFromPtr ptr = if ptr == nullPtr+                   then Nothing+                   else Just ptr++-- | Given a function and a list of two-tuples, apply the function to+-- every first element of the tuples.+mapFirst :: (a -> c) -> [(a,b)] -> [(c,b)]+mapFirst _ [] = []+mapFirst f ((x,y) : rest) = (f x, y) : mapFirst f rest++-- | Same for the second element.+mapSecond :: (b -> c) -> [(a,b)] -> [(a,c)]+mapSecond _ [] = []+mapSecond f ((x,y) : rest) = (x, f y) : mapSecond f rest++-- | Applicative version of `mapFirst`.+mapFirstA :: Applicative f => (a -> f c) -> [(a,b)] -> f [(c,b)]+mapFirstA _ [] = pure []+mapFirstA f ((x,y) : rest) = (:) <$> ((,y) <$> f x) <*> mapFirstA f rest++-- | Applicative version of `mapSecond`.+mapSecondA :: Applicative f => (b -> f c) -> [(a,b)] -> f [(a,c)]+mapSecondA _ [] = pure []+mapSecondA f ((x,y) : rest) = (:) <$> ((x,) <$> f y) <*> mapSecondA f rest++-- | Apply the given conversion action to the given pointer if it is+-- non-NULL, otherwise return `Nothing`.+convertIfNonNull :: Ptr a -> (Ptr a -> IO b) -> IO (Maybe b)+convertIfNonNull ptr convert = if ptr == nullPtr+                               then return Nothing+                               else Just <$> convert ptr++foreign import ccall "g_malloc0" g_malloc0 ::+    #{type gsize} -> IO (Ptr a)++-- | Make a zero-filled allocation using the GLib allocator.+{-# INLINE callocBytes #-}+callocBytes :: Int -> IO (Ptr a)+callocBytes n =  g_malloc0 (fromIntegral n)++foreign import ccall "g_boxed_copy" g_boxed_copy ::+    CGType -> Ptr a -> IO (Ptr a)++-- | Make a zero filled allocation of n bytes for a boxed object. The+-- difference with a normal callocBytes is that the returned memory is+-- allocated using whatever memory allocator g_boxed_copy uses, which+-- in particular may well be different from a plain g_malloc. In+-- particular g_slice_alloc is often used for allocating boxed+-- objects, which are then freed using g_slice_free.+callocBoxedBytes :: forall a. BoxedObject a => Int -> IO (Ptr a)+callocBoxedBytes n = do+  ptr <- callocBytes n+  GType cgtype <- boxedType (undefined :: a)+  result <- g_boxed_copy cgtype ptr+  freeMem ptr+  return result++foreign import ccall "g_malloc" g_malloc ::+    #{type gsize} -> IO (Ptr a)++-- | Allocate the given number of bytes using the GLib allocator.+{-# INLINE allocBytes #-}+allocBytes :: Integral a => a -> IO (Ptr b)+allocBytes n = g_malloc (fromIntegral n)++-- | Allocate space for the given `Storable` using the GLib allocator.+{-# INLINE allocMem #-}+allocMem :: forall a. Storable a => IO (Ptr a)+allocMem = g_malloc $ (fromIntegral . sizeOf) (undefined :: a)++-- | A wrapped for `g_free`.+foreign import ccall "g_free" freeMem :: Ptr a -> IO ()++-- | Pointer to `g_free`.+foreign import ccall "&g_free" ptr_to_g_free :: FunPtr (Ptr a -> IO ())++foreign import ccall unsafe "string.h memcpy" _memcpy :: Ptr a -> Ptr b -> CSize -> IO (Ptr ())++-- | Copy memory into a destination (in the first argument) from a+-- source (in the second argument).+{-# INLINE memcpy #-}+memcpy :: Ptr a -> Ptr b -> Int -> IO ()+memcpy dest src n = void $ _memcpy dest src (fromIntegral n)++-- | Same as freeHaskellFunPtr, but it does nothing when given a+-- nullPtr.+foreign import ccall "safeFreeFunPtr" safeFreeFunPtr ::+    Ptr a -> IO ()++-- | A pointer to `safeFreeFunPtr`.+foreign import ccall "& safeFreeFunPtr" safeFreeFunPtrPtr ::+    FunPtr (Ptr a -> IO ())++-- | If given a pointer to the memory location, free the `FunPtr` at+-- that location, and then the pointer itself. Useful for freeing the+-- memory associated to callbacks which are called just once, with no+-- destroy notification.+maybeReleaseFunPtr :: Maybe (Ptr (FunPtr a)) -> IO ()+maybeReleaseFunPtr Nothing = return ()+maybeReleaseFunPtr (Just f) = do+  peek f >>= freeHaskellFunPtr+  freeMem f
+ src/c/hsgclosure.c view
@@ -0,0 +1,94 @@+#define _GNU_SOURCE++/* GHC's semi-public Rts API */+#include <Rts.h>++#include <stdlib.h>++#include <glib-object.h>++int check_object_type(void *instance, GType type)+{+  int result;++  if (instance != NULL) {+     result = !!G_TYPE_CHECK_INSTANCE_TYPE(instance, type);+  } else {+    result = 0;+    fprintf(stderr, "Check failed: got a null pointer\n");+  }++  return result;+}++static int print_debug_info ()+{+  static int __print_debug_info = -1;++  if (__print_debug_info == -1) {+    __print_debug_info = secure_getenv ("HASKELL_GI_DEBUG_MEM") != NULL;+  }++  return __print_debug_info;+}++/* Auxiliary function for freeing boxed types */+void boxed_free_helper (GType *gtype, void *boxed)+{+  if (print_debug_info()) {+    fprintf(stderr, "Freeing a boxed object at %p\n", boxed);+    fprintf(stderr, "\tIt is of type %s\n", g_type_name(*gtype));+  }++  g_boxed_free (*gtype, boxed);+  g_free (gtype);++  if (print_debug_info()) {+    fprintf(stderr, "\tdone\n");+  }+}++void dbg_g_object_unref (GObject *obj)+{+  GType gtype;++  if (print_debug_info()) {+    fprintf(stderr, "Freeing a GObject at %p\n", obj);+    gtype = G_TYPE_FROM_INSTANCE (obj);+    fprintf(stderr, "\tIt is of type %s\n", g_type_name(gtype));+    fprintf(stderr, "\tIts refcount before unref is %d\n",+            (int)obj->ref_count);+  }++  g_object_unref(obj);++  if (print_debug_info()) {+    fprintf(stderr, "\tdone\n");+  }+}++gpointer dbg_g_object_newv (GType gtype, guint n_params, GParameter *params)+{+  gpointer result;++  if (print_debug_info()) {+    fprintf(stderr, "Creating a new GObject of type %s\n",+            g_type_name(gtype));+  }++  result = g_object_newv (gtype, n_params, params);++  if (print_debug_info()) {+    fprintf(stderr, "\tdone, got a pointer at %p\n", result);+  }++  return result;+}++/* Same as freeHaskellFunctionPtr, but it does nothing when given a+   null pointer, instead of crashing */+void safeFreeFunPtr(void *ptr)+{+  if (ptr != NULL)+    freeHaskellFunctionPtr(ptr);+}