packages feed

haskell-gi (empty) → 0.8

raw patch · 45 files changed

+6468/−0 lines, 45 filesdep +basedep +bytestringdep +containerssetup-changed

Dependencies added: base, bytestring, containers, directory, file-embed, filepath, free, haskell-gi-base, mtl, pretty-show, process, safe, text, transformers, xdg-basedir, xml-conduit

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.cabal view
@@ -0,0 +1,88 @@+name:                haskell-gi+version:             0.8+synopsis:            Generate Haskell bindings for GObject Introspection capable libraries+description:         Generate Haskell bindings for GObject Introspection capable libraries. This includes most notably+                     Gtk+, but many other libraries in the GObject ecosystem provide introspection data too.+homepage:            https://github.com/haskell-gi/haskell-gi+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.git++executable haskell-gi+  main-is:             haskell-gi.hs+  pkgconfig-depends:   gobject-introspection-1.0 >= 1.42, gobject-2.0 >= 2.36+  build-depends:       base >= 4.7 && < 5,+                       containers,+                       directory,+                       filepath,+                       file-embed >= 0.0.9,+                       mtl >= 2.2,+                       transformers >= 0.3,+                       pretty-show,+                       process,+                       safe,+                       bytestring,+                       xdg-basedir,+                       xml-conduit >= 1.3.0,+                       haskell-gi-base == 0.8,+                       text >= 1.0,+                       free++  build-tools:         hsc2hs, c2hs+  hs-source-dirs:      src+  other-modules:       GI.GIR.Alias,+                       GI.GIR.BasicTypes,+                       GI.GIR.Callback,+                       GI.GIR.Constant,+                       GI.GIR.Deprecation,+                       GI.GIR.Enum,+                       GI.GIR.Field,+                       GI.GIR.Flags,+                       GI.GIR.Method,+                       GI.GIR.Object,+                       GI.GIR.Parser,+                       GI.GIR.Repository,+                       GI.GIR.Signal,+                       GI.GIR.Struct,+                       GI.GIR.Type,+                       GI.GIR.Union,+                       GI.GIR.XMLUtils,+                       GI.API,+                       GI.Attributes,+                       GI.Cabal,+                       GI.Callable,+                       GI.Code,+                       GI.Config,+                       GI.Constant,+                       GI.Conversions,+                       GI.GObject,+                       GI.GType,+                       GI.Inheritance,+                       GI.OverloadedSignals,+                       GI.Overrides,+                       GI.PkgConfig,+                       GI.ProjectInfo,+                       GI.Properties,+                       GI.LibGIRepository,+                       GI.Signal,+                       GI.Struct,+                       GI.SymbolNaming,+                       GI.Transfer,+                       GI.Type,+                       GI.Util++  extensions:          CPP, ForeignFunctionInterface, DoAndIfThenElse, LambdaCase, RankNTypes, OverloadedStrings+  ghc-options:         -Wall -fno-warn-missing-signatures -fwarn-incomplete-patterns -fno-warn-name-shadowing+  c-sources:           src/c/enumStorage.c
+ src/GI/API.hs view
@@ -0,0 +1,397 @@+{-# LANGUAGE RecordWildCards, NamedFieldPuns #-}++module GI.API+    ( API(..)+    , GIRInfo(..)+    , loadGIRInfo+    , loadRawGIRInfo++    -- Reexported from GI.GIR.BasicTypes+    , Name(..)+    , Transfer(..)++    -- Reexported from GI.GIR.Arg+    , Direction(..)+    , Scope(..)++    -- Reexported from GI.GIR.Deprecation+    , deprecatedPragma+    , DeprecationInfo++    -- Reexported from GI.GIR.Property+    , PropertyFlag(..)++    -- Reexported from GI.GIR.Method+    , MethodType(..)++    -- Reexported from the corresponding GI.GIR modules+    , Constant(..)+    , Arg(..)+    , Callable(..)+    , Function(..)+    , Signal(..)+    , Property(..)+    , Field(..)+    , Struct(..)+    , Callback(..)+    , Interface(..)+    , Method(..)+    , Object(..)+    , Enumeration(..)+    , Flags (..)+    , Union (..)+    ) where++import Control.Monad ((>=>), forM, forM_)+import qualified Data.List as L+import qualified Data.Map as M+import Data.Maybe (mapMaybe, catMaybes)+import Data.Monoid ((<>))+import qualified Data.Set as S+import qualified Data.Text as T+import Data.Text (Text)++import Foreign.Ptr (Ptr)+import Foreign (peek)+import Foreign.C.Types (CUInt)++import Text.XML hiding (Name)++import GI.GIR.Alias (documentListAliases)+import GI.GIR.Arg (Arg(..), Direction(..), Scope(..))+import GI.GIR.BasicTypes (Alias, Name(..), Transfer(..))+import GI.GIR.Callable (Callable(..))+import GI.GIR.Callback (Callback(..), parseCallback)+import GI.GIR.Constant (Constant(..), parseConstant)+import GI.GIR.Deprecation (DeprecationInfo, deprecatedPragma)+import GI.GIR.Enum (Enumeration(..), parseEnum)+import GI.GIR.Field (Field(..))+import GI.GIR.Flags (Flags(..), parseFlags)+import GI.GIR.Function (Function(..), parseFunction)+import GI.GIR.Interface (Interface(..), parseInterface)+import GI.GIR.Method (Method(..), MethodType(..))+import GI.GIR.Object (Object(..), parseObject)+import GI.GIR.Parser (Parser, runParser)+import GI.GIR.Property (Property(..), PropertyFlag(..))+import GI.GIR.Repository (readGiRepository)+import GI.GIR.Signal (Signal(..))+import GI.GIR.Struct (Struct(..), parseStruct)+import GI.GIR.Union (Union(..), parseUnion)+import GI.GIR.XMLUtils (subelements, childElemsWithLocalName, lookupAttr,+                        lookupAttrWithNamespace, GIRXMLNamespace(..))++import Data.GI.Base.BasicConversions (unpackStorableArrayWithLength)+import Data.GI.Base.BasicTypes (GType(..), CGType, gtypeName)+import Data.GI.Base.Utils (allocMem, freeMem)+import GI.LibGIRepository (girRequire, girStructSizeAndOffsets,+                           girUnionSizeAndOffsets, girLoadGType)+import GI.GType (gtypeIsBoxed)+import GI.Type (Type)++data GIRInfo = GIRInfo {+      girPCPackages      :: [Text],+      girNSName          :: Text,+      girNSVersion       :: Text,+      girAPIs            :: [(Name, API)],+      girCTypes          :: M.Map Text Name+    } deriving Show++data GIRNamespace = GIRNamespace {+      nsName      :: Text,+      nsVersion   :: Text,+      nsAPIs      :: [(Name, API)],+      nsCTypes    :: [(Text, Name)]+    } deriving (Show)++data GIRInfoParse = GIRInfoParse {+    girIPPackage    :: [Maybe Text],+    girIPIncludes   :: [Maybe (Text, Text)],+    girIPNamespaces :: [Maybe GIRNamespace]+} deriving (Show)++data API+    = APIConst Constant+    | APIFunction Function+    | APICallback Callback+    | APIEnum Enumeration+    | APIFlags Flags+    | APIInterface Interface+    | APIObject Object+    | APIStruct Struct+    | APIUnion Union+    deriving Show++parseAPI :: Text -> M.Map Alias Type -> Element -> (a -> API)+         -> Parser (Name, a) -> (Name, API)+parseAPI ns aliases element wrapper parser =+    case runParser ns aliases element parser of+      Left err -> error $ "Parse error: " ++ T.unpack err+      Right (n, a) -> (n, wrapper a)++parseNSElement :: M.Map Alias Type -> GIRNamespace -> Element -> GIRNamespace+parseNSElement aliases ns@GIRNamespace{..} element+    | lookupAttr "introspectable" element == Just "0" = ns+    | otherwise =+        case nameLocalName (elementName element) of+          "alias" -> ns     -- Processed separately+          "constant" -> parse APIConst parseConstant+          "enumeration" -> parse APIEnum parseEnum+          "bitfield" -> parse APIFlags parseFlags+          "function" -> parse APIFunction parseFunction+          "callback" -> parse APICallback parseCallback+          "record" -> parse APIStruct parseStruct+          "union" -> parse APIUnion parseUnion+          "class" -> parse APIObject parseObject+          "interface" -> parse APIInterface parseInterface+          "boxed" -> ns -- Unsupported+          n -> error . T.unpack $ "Unknown GIR element \"" <> n <> "\" when processing namespace \"" <> nsName <> "\", aborting."+    where parse :: (a -> API) -> Parser (Name, a) -> GIRNamespace+          parse wrapper parser =+              let (n, api) = parseAPI nsName aliases element wrapper parser+                  maybeCType = lookupAttrWithNamespace CGIRNS "type" element+              in ns { nsAPIs = (n, api) : nsAPIs,+                      nsCTypes = case maybeCType of+                                   Just ctype -> (ctype, n) : nsCTypes+                                   Nothing -> nsCTypes+                    }++parseNamespace :: Element -> M.Map Alias Type -> Maybe GIRNamespace+parseNamespace element aliases = do+  let attrs = elementAttributes element+  name <- M.lookup "name" attrs+  version <- M.lookup "version" attrs+  let ns = GIRNamespace {+             nsName         = name,+             nsVersion      = version,+             nsAPIs         = [],+             nsCTypes       = []+           }+  return (L.foldl' (parseNSElement aliases) ns (subelements element))++parseInclude :: Element -> Maybe (Text, Text)+parseInclude element = do+  name <- M.lookup "name" attrs+  version <- M.lookup "version" attrs+  return (name, version)+      where attrs = elementAttributes element++parsePackage :: Element -> Maybe Text+parsePackage element = M.lookup "name" (elementAttributes element)++parseRootElement :: M.Map Alias Type -> GIRInfoParse -> Element -> GIRInfoParse+parseRootElement aliases info@GIRInfoParse{..} element =+    case nameLocalName (elementName element) of+      "include" -> info {girIPIncludes = parseInclude element : girIPIncludes}+      "package" -> info {girIPPackage = parsePackage element : girIPPackage}+      "namespace" -> info {girIPNamespaces = parseNamespace element aliases : girIPNamespaces}+      _ -> info++emptyGIRInfoParse :: GIRInfoParse+emptyGIRInfoParse = GIRInfoParse {+                      girIPPackage = [],+                      girIPIncludes = [],+                      girIPNamespaces = []+                    }++parseGIRDocument :: M.Map Alias Type -> Document -> GIRInfoParse+parseGIRDocument aliases doc = L.foldl' (parseRootElement aliases) emptyGIRInfoParse (subelements (documentRoot doc))++-- | Parse the list of includes in a given document.+documentListIncludes :: Document -> S.Set (Text, Text)+documentListIncludes doc = S.fromList (mapMaybe parseInclude includes)+    where includes = childElemsWithLocalName "include" (documentRoot doc)++-- | Load a set of dependencies, recursively.+loadDependencies :: Bool                              -- Verbose+                 -> S.Set (Text, Text)                -- Requested+                 -> M.Map (Text, Text) Document       -- Loaded so far+                 -> [FilePath]                        -- extra path to search+                 -> IO (M.Map (Text, Text) Document)  -- New loaded set+loadDependencies verbose requested loaded extraPaths+        | S.null requested = return loaded+        | otherwise = do+  let (name, version) = S.elemAt 0 requested+  doc <- readGiRepository verbose name (Just version) extraPaths+  let newLoaded = M.insert (name, version) doc loaded+      newRequested = S.union requested (documentListIncludes doc)+      notYetLoaded = S.filter (/= (name, version)) newRequested+  loadDependencies verbose notYetLoaded newLoaded extraPaths++-- | Load a given GIR file and recursively its dependencies+loadGIRFile :: Bool             -- ^ verbose+            -> Text             -- ^ name+            -> Maybe Text       -- ^ version+            -> [FilePath]       -- ^ extra paths to search+            -> IO (Document,                    -- ^ loaded document+                   M.Map (Text, Text) Document) -- ^ dependencies+loadGIRFile verbose name version extraPaths = do+  doc <- readGiRepository verbose name version extraPaths+  deps <- loadDependencies verbose (documentListIncludes doc) M.empty extraPaths+  return (doc, deps)++-- | Turn a GIRInfoParse into a proper GIRInfo, doing some sanity+-- checking along the way.+toGIRInfo :: GIRInfoParse -> Either Text GIRInfo+toGIRInfo info =+    case catMaybes (girIPNamespaces info) of+      [ns] -> Right GIRInfo {+                girPCPackages = (reverse . catMaybes . girIPPackage) info+              , girNSName = nsName ns+              , girNSVersion = nsVersion ns+              , girAPIs = reverse (nsAPIs ns)+              , girCTypes = M.fromList (nsCTypes ns)+              }+      [] -> Left "Found no valid namespace."+      _  -> Left "Found multiple namespaces."++-- | Bare minimum loading and parsing of a single repository, without+-- loading or parsing its dependencies, resolving aliases, or fixing+-- up structs or interfaces.+loadRawGIRInfo :: Bool          -- ^ verbose+               -> Text          -- ^ name+               -> Maybe Text    -- ^ version+               -> [FilePath]    -- ^ extra paths to search+               -> IO GIRInfo    -- ^ bare parsed document+loadRawGIRInfo verbose name version extraPaths = do+  doc <- readGiRepository verbose name version extraPaths+  case toGIRInfo (parseGIRDocument M.empty doc) of+    Left err -> error . T.unpack $ "Error when raw parsing \"" <> name <> "\": " <> err+    Right docGIR -> return docGIR++-- | Load and parse a GIR file, including its dependencies.+loadGIRInfo :: Bool             -- ^ verbose+            -> Text             -- ^ name+            -> Maybe Text       -- ^ version+            -> [FilePath]       -- ^ extra paths to search+            -> IO (GIRInfo,     -- ^ parsed document+                   [GIRInfo])   -- ^ parsed deps+loadGIRInfo verbose name version extraPaths =  do+  (doc, deps) <- loadGIRFile verbose name version extraPaths+  let aliases = M.unions (map documentListAliases (doc : M.elems deps))+      parsedDoc = toGIRInfo (parseGIRDocument aliases doc)+      parsedDeps = map (toGIRInfo . parseGIRDocument aliases) (M.elems deps)+  case combineErrors parsedDoc parsedDeps of+    Left err -> error . T.unpack $ "Error when parsing \"" <> name <> "\": " <> err+    Right (docGIR, depsGIR) -> do+      if girNSName docGIR == name+      then do+        forM_ (docGIR : depsGIR) $ \info ->+            girRequire (girNSName info) (girNSVersion info)+        (fixedDoc, fixedDeps) <- fixupGIRInfos docGIR depsGIR+        return (fixedDoc, fixedDeps)+      else error . T.unpack $ "Got unexpected namespace \""+               <> girNSName docGIR <> "\" when parsing \"" <> name <> "\"."+  where combineErrors :: Either Text GIRInfo -> [Either Text GIRInfo]+                      -> Either Text (GIRInfo, [GIRInfo])+        combineErrors parsedDoc parsedDeps = do+          doc <- parsedDoc+          deps <- sequence parsedDeps+          return (doc, deps)++foreign import ccall "g_type_interface_prerequisites" g_type_interface_prerequisites :: CGType -> Ptr CUInt -> IO (Ptr CGType)++-- | List the prerequisites for a 'GType' corresponding to an interface.+gtypeInterfaceListPrereqs :: GType -> IO [Text]+gtypeInterfaceListPrereqs (GType cgtype) = do+  nprereqsPtr <- allocMem :: IO (Ptr CUInt)+  ps <- g_type_interface_prerequisites cgtype nprereqsPtr+  nprereqs <- peek nprereqsPtr+  psCGTypes <- unpackStorableArrayWithLength nprereqs ps+  freeMem ps+  freeMem nprereqsPtr+  mapM (fmap T.pack . gtypeName . GType) psCGTypes++-- | The list of prerequisites in GIR files is not always+-- accurate. Instead of relying on this, we instantiate the 'GType'+-- associated to the interface, and listing the interfaces from there.+fixupInterface :: M.Map Text Name -> (Name, API) -> IO (Name, API)+fixupInterface csymbolMap (n@(Name ns _), APIInterface iface) = do+  prereqs <- case ifTypeInit iface of+               Nothing -> return []+               Just ti -> do+                 gtype <- girLoadGType (T.pack ns) ti+                 prereqGTypes <- gtypeInterfaceListPrereqs gtype+                 forM prereqGTypes $ \p -> do+                   case M.lookup p csymbolMap of+                     Just pn -> return pn+                     Nothing -> error $ "Could not find prerequisite type " ++ show p ++ " for interface " ++ show n+  return (n, APIInterface (iface {ifPrerequisites = prereqs}))+fixupInterface _ (n, api) = return (n, api)++-- | There is not enough info in the GIR files to determine whether a+-- struct is boxed. We find out by instantiating the 'GType'+-- corresponding to the struct (if known) and checking whether it+-- descends from the boxed GType. Similarly, the size of the struct+-- and offset of the fields is hard to compute from the GIR data, we+-- simply reuse the machinery in libgirepository.+fixupStruct :: M.Map Text Name -> (Name, API) -> IO (Name, API)+fixupStruct _ (n, APIStruct s) = do+  fixed <- (fixupStructIsBoxed n >=> fixupStructSizeAndOffsets n) s+  return (n, APIStruct fixed)+fixupStruct _ api = return api++-- | Find out whether the struct is boxed.+fixupStructIsBoxed :: Name -> Struct -> IO Struct+-- The type for "GVariant" is marked as "intern", we wrap+-- this one natively.+fixupStructIsBoxed (Name "GLib" "Variant") s =+    return (s {structIsBoxed = False})+fixupStructIsBoxed (Name ns _) s = do+  isBoxed <- case structTypeInit s of+               Nothing -> return False+               Just ti -> do+                 gtype <- girLoadGType (T.pack ns) ti+                 return (gtypeIsBoxed gtype)+  return (s {structIsBoxed = isBoxed})++-- | Fix the size and alignment of fields. This is much easier to do+-- by using libgirepository than reading the GIR file directly.+fixupStructSizeAndOffsets :: Name -> Struct -> IO Struct+fixupStructSizeAndOffsets (Name ns n) s = do+  (size, offsetMap) <- girStructSizeAndOffsets (T.pack ns) (T.pack n)+  return (s { structSize = size+            , structFields = map (fixupField offsetMap) (structFields s)})++-- | Same thing for unions.+fixupUnion :: M.Map Text Name -> (Name, API) -> IO (Name, API)+fixupUnion _ (n, APIUnion u) = do+  fixed <- (fixupUnionSizeAndOffsets n) u+  return (n, APIUnion fixed)+fixupUnion _ api = return api++-- | Like 'fixupStructSizeAndOffset' above.+fixupUnionSizeAndOffsets :: Name -> Union -> IO Union+fixupUnionSizeAndOffsets (Name ns n) u = do+  (size, offsetMap) <- girUnionSizeAndOffsets (T.pack ns) (T.pack n)+  return (u { unionSize = size+            , unionFields = map (fixupField offsetMap) (unionFields u)})++-- | Fixup the offsets of fields using the given offset map.+fixupField :: M.Map Text Int -> Field -> Field+fixupField offsetMap f =+    f {fieldOffset = case M.lookup (fieldName f) offsetMap of+                       Nothing -> error $ "Could not find field "+                                  ++ show (fieldName f)+                       Just o -> o }++-- | Fixup parsed GIRInfos: some of the required information is not+-- found in the GIR files themselves, but can be obtained by+-- instantiating the required GTypes from the installed libraries.+fixupGIRInfos :: GIRInfo -> [GIRInfo] -> IO (GIRInfo, [GIRInfo])+fixupGIRInfos doc deps = (fixup fixupInterface >=>+                          fixup fixupStruct >=>+                          fixup fixupUnion) (doc, deps)+  where fixup :: (M.Map Text Name -> (Name, API) -> IO (Name, API))+                 -> (GIRInfo, [GIRInfo]) -> IO (GIRInfo, [GIRInfo])+        fixup fixer (doc, deps) = do+          fixedDoc <- fixAPIs fixer doc+          fixedDeps <- mapM (fixAPIs fixer) deps+          return (fixedDoc, fixedDeps)++        fixAPIs :: (M.Map Text Name -> (Name, API) -> IO (Name, API)) -> GIRInfo -> IO GIRInfo+        fixAPIs fixer info = do+          fixedAPIs <- mapM (fixer ctypes) (girAPIs info)+          return $ info {girAPIs = fixedAPIs}++        ctypes :: M.Map Text Name+        ctypes = M.unions (map girCTypes (doc:deps))
+ src/GI/Attributes.hs view
@@ -0,0 +1,91 @@+module GI.Attributes+    ( genAttributes+    , genAllAttributes+    ) where++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative ((<$>))+#endif+import Control.Monad (forM_, when)+import Control.Monad.Writer (tell)+import qualified Data.Set as S+import qualified Data.Text as T+import Data.Text (Text)++import GI.API+import GI.Code+import GI.SymbolNaming+import GI.Properties+import GI.CodeGen (genPrelude)++-- A list of distinct property names for all GObjects appearing in the+-- given list of APIs.+findObjectPropNames :: [(Name, API)] -> CodeGen [Text]+findObjectPropNames apis = S.toList <$> go apis S.empty+    where+      go :: [(Name, API)] -> S.Set Text -> CodeGen (S.Set Text)+      go [] set = return set+      go ((_, api):apis) set =+        case api of+          APIInterface iface ->+              go apis $ insertProps (ifProperties iface) set+          APIObject object ->+              go apis $ insertProps (objProperties object) set+          _ -> go apis set++      insertProps :: [Property] -> S.Set Text -> S.Set Text+      insertProps props set = S.union set ((S.fromList . map propName) props)++genPropertyAttr :: Text -> CodeGen ()+genPropertyAttr pName = group $ do+  line $ "-- Property \"" ++ T.unpack pName ++ "\""+  let name = (hyphensToCamelCase  . T.unpack) pName+  line $ "_" ++ lcFirst name ++ " :: Proxy \"" ++ T.unpack pName ++ "\""+  line $ "_" ++ lcFirst name ++ " = Proxy"++genAllAttributes :: [(Name, API)] -> String -> CodeGen ()+genAllAttributes allAPIs modulePrefix = do+  line "-- Generated code."+  blank+  line "{-# LANGUAGE DataKinds #-}"+  blank++  line $ "module " ++ modulePrefix ++ "Properties where"+  blank+  line $ "import Data.Proxy (Proxy(..))"+  blank++  propNames <- findObjectPropNames allAPIs+  forM_ propNames $ \name -> do+      genPropertyAttr name+      blank++genProps :: (Name, API) -> CodeGen ()+genProps (n, APIObject o) = genObjectProperties n o+genProps (n, APIInterface i) = genInterfaceProperties n i+genProps _ = return ()++genAttributes :: String -> [(Name, API)] -> String -> CodeGen ()+genAttributes name apis modulePrefix = do+  let mp = (modulePrefix ++)+      nm = ucFirst name++  code <- recurse' $ forM_ apis genProps++  -- Providing orphan instances is the whole point of these modules,+  -- tell GHC that this is fine.+  line "{-# OPTIONS_GHC -fno-warn-orphans -fno-warn-unused-imports #-}"+  blank++  genPrelude (nm ++ "Attributes") modulePrefix++  deps <- getDeps+  forM_ (S.toList deps) $ \i -> when (i /= name) $ do+    line $ "import qualified " ++ mp (ucFirst i) ++ " as " ++ ucFirst i+    line $ "import qualified " ++ mp (ucFirst i) ++ "Attributes as "+             ++ ucFirst i ++ "A"++  line $ "import " ++ modulePrefix ++ nm+  blank++  tell code
+ src/GI/Cabal.hs view
@@ -0,0 +1,180 @@+module GI.Cabal+    ( genCabalProject+    , cabalConfig+    , setupHs+    ) where++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative ((<$>), (<*>))+#endif+import Control.Monad (forM_)+import Control.Monad.IO.Class (liftIO)+import Data.List (intercalate)+import Data.Maybe (fromMaybe)+import Data.Monoid ((<>))+import Data.Version (Version(..),  showVersion)+#if MIN_VERSION_base(4,8,0)+import Data.Version (makeVersion)+#endif+import qualified Data.Map as M+import qualified Data.Text as T+import Data.Text (Text)+import Text.Read++import GI.API (GIRInfo(..))+import GI.Code+import GI.Config (Config(..))+import GI.Overrides (pkgConfigMap, cabalPkgVersion)+import GI.PkgConfig (pkgConfigGetVersion)+import GI.ProjectInfo (homepage, license, authors, maintainers)+import GI.Util (padTo)+import GI.SymbolNaming (ucFirst)++import Paths_haskell_gi (version)++cabalConfig :: Text+cabalConfig = T.unlines ["documentation: False",+                         "optimization: False"]++setupHs :: Text+setupHs = T.unlines ["#!/usr/bin/env runhaskell",+                     "import Distribution.Simple",+                     "main = defaultMain"]++haskellGIAPIVersion :: Int+haskellGIAPIVersion = (head . versionBranch) version++#if !MIN_VERSION_base(4,8,0)+-- Create a version without tags, which we ignore anyway. The+-- versionTags constructor field is deprecated in base 4.8.0.+makeVersion :: [Int] -> Version+makeVersion branch = Version branch []+#endif++haskellGIRevision :: String+haskellGIRevision =+    showVersion $ makeVersion (tail (versionBranch version))++{- |++If the haskell-gi version is of the form x.y and the pkgconfig version+of the package being wrapped is a.b.c, this gives something of the+form x.a.b.y.++This strange seeming-rule is so that the packages that we produce+follow the PVP, assuming that the package being wrapped follows the+usual semantic versioning convention (http://semver.org) that+increases in "a" indicate non-backwards compatible changes, increases+in "b" backwards compatible additions to the API, and increases in "c"+denote API compatible changes (so we do not need to regenerate+bindings for these, at least in principle, so we do not encode them in+the cabal version).++In order to follow the PVP, then everything we need to do in the+haskell-gi side is to increase x everytime the generated API changes+(for a fixed a.b.c version).++In any case, if such "strange" package numbers are undesired, or the+wrapped package does not follow semver, it is possible to add an+explicit cabal-pkg-version override. This needs to be maintained by+hand (including in the list of dependencies of packages depending on+this one), so think carefully before using this override!++-}+giModuleVersion :: Int -> Int -> Text+giModuleVersion major minor = T.pack $+    show haskellGIAPIVersion ++ "." ++ show major ++ "."+             ++ show minor ++ "." ++ haskellGIRevision++-- | Smallest version not backwards compatible with the current+-- version (according to PVP).+nextIncompatibleVersion :: Int -> Text+nextIncompatibleVersion major = T.pack $+    show haskellGIAPIVersion ++ "." ++ show (major+1)++-- | Determine the pkg-config name and installed version (major.minor+-- only) for a given module, or throw an exception if that fails.+tryPkgConfig :: Text -> Text -> [Text] -> Bool+             -> M.Map Text Text+             -> ExcCodeGen (Text, Int, Int)+tryPkgConfig name version packages verbose overridenNames =+    liftIO (pkgConfigGetVersion name version packages verbose overridenNames) >>= \case+           Just (n,v) ->+               case readMajorMinor v of+                 Just (major, minor) -> return (n, major, minor)+                 Nothing -> notImplementedError . T.unpack $+                            "Cannot parse version \""+                            <> v <> "\" for module " <> name+           Nothing -> missingInfoError . T.unpack $+                      "Could not determine the pkg-config name corresponding to \"" <> name <> "\".\n" <>+                      "Try adding an override with the proper package name:\n"+                      <> "pkg-config-name " <> name <> " [matching pkg-config name here]"++-- | Given a string a.b.c..., representing a version number, determine+-- the major and minor versions, i.e. "a" and "b". If successful,+-- return (a,b).+readMajorMinor :: Text -> Maybe (Int, Int)+readMajorMinor version =+    case T.splitOn "." version of+      (a:b:_) -> (,) <$> readMaybe (T.unpack a) <*> readMaybe (T.unpack b)+      _ -> Nothing++-- | Try to generate the cabal project. In case of error return the+-- corresponding error string.+genCabalProject :: GIRInfo -> [GIRInfo] -> String -> CodeGen (Maybe String)+genCabalProject gir deps modulePrefix =+    handleCGExc (return . Just . describeCGError) $ do+      cfg <- config+      let pkMap = pkgConfigMap (overrides cfg)+          name = girNSName gir+          pkgVersion = girNSVersion gir+          packages = girPCPackages gir++      line $ "-- Autogenerated, do not edit."+      line $ padTo 20 "name:" <> "gi-" <> T.unpack (T.toLower name)+      (pcName, major, minor) <- tryPkgConfig name pkgVersion packages (verbose cfg) pkMap+      let cabalVersion = fromMaybe (giModuleVersion major minor)+                                   (cabalPkgVersion $ overrides cfg)+      line $ padTo 20 "version:" ++ T.unpack cabalVersion+      line $ padTo 20 "synopsis:" ++ T.unpack name+               ++ " bindings"+      line $ padTo 20 "description:" ++ "Bindings for " ++ T.unpack name+               ++ ", autogenerated by haskell-gi."+      line $ padTo 20 "homepage:" ++ homepage+      line $ padTo 20 "license:" ++ license+      line $ padTo 20 "license-file:" ++ "LICENSE"+      line $ padTo 20 "author:" ++ authors+      line $ padTo 20 "maintainer:" ++ maintainers+      line $ padTo 20 "category:" ++ "Bindings"+      line $ padTo 20 "build-type:" ++ "Simple"+      line $ padTo 20 "cabal-version:" ++ ">=1.10"+      blank+      line $ "library"+      indent $ do+        line $ padTo 20 "default-language:" ++ "Haskell2010"+        let base = modulePrefix ++ ucFirst (T.unpack name)+        line $ padTo 20 "exposed-modules:" +++               intercalate ", " [base, base ++ "Attributes", base ++ "Signals"]+        line $ padTo 20 "pkgconfig-depends:" ++ T.unpack pcName ++ " >= "+                 ++ show major ++ "." ++ show minor+        line $ padTo 20 "build-depends: base >= 4.6 && <4.9,"+        indent $ do+          line $ "haskell-gi-base >= " ++ showVersion version+                 ++ " && < " ++ show (haskellGIAPIVersion + 1) ++ ","+          forM_ deps $ \dep -> do+              let depName = girNSName dep+                  depVersion = girNSVersion dep+                  depPackages = girPCPackages dep+              (_, depMajor, depMinor) <- tryPkgConfig depName depVersion+                                         depPackages (verbose cfg) pkMap+              line . T.unpack $ "gi-" <> T.toLower depName <> " >= "+                       <> giModuleVersion depMajor depMinor+                       <> " && < " <> nextIncompatibleVersion depMajor <> ","+          -- Our usage of these is very basic, no reason to put any+          -- strong upper bounds.+          line "bytestring >= 0.10,"+          line "containers >= 0.5,"+          line "text >= 1.0,"+          line "transformers >= 0.3"++      return Nothing -- successful generation, no error
+ src/GI/Callable.hs view
@@ -0,0 +1,697 @@+{-# LANGUAGE LambdaCase #-}+module GI.Callable+    ( genCallable++    , hOutType+    , arrayLengths+    , arrayLengthsMap++    , wrapMaybe+    , inArgInterfaces+    ) where++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative ((<$>))+#endif+import Control.Monad (forM, forM_, when)+import Data.Bool (bool)+import Data.List (intercalate, nub, (\\))+import Data.Maybe (isJust)+import Data.Typeable (TypeRep, tyConName, typeRepTyCon, typeOf)+import qualified Data.Map as Map+import qualified Data.Text as T+import Data.Text (Text)++import GI.API+import GI.Code+import GI.Conversions+import GI.SymbolNaming+import GI.Transfer+import GI.Type+import GI.Util++import Text.Show.Pretty (ppShow)++hOutType :: Callable -> [Arg] -> Bool -> ExcCodeGen TypeRep+hOutType callable outArgs ignoreReturn = do+  hReturnType <- case returnType callable of+                   TBasicType TVoid -> return $ typeOf ()+                   _                -> if ignoreReturn+                                       then return $ typeOf ()+                                       else haskellType $ returnType callable+  hOutArgTypes <- forM outArgs $ \outarg ->+                  wrapMaybe outarg >>= bool+                                (haskellType (argType outarg))+                                (maybeT <$> haskellType (argType outarg))+  let maybeHReturnType = if returnMayBeNull callable && not ignoreReturn+                         then maybeT hReturnType+                         else hReturnType+  return $ case (outArgs, show maybeHReturnType) of+             ([], _)   -> maybeHReturnType+             (_, "()") -> "(,)" `con` hOutArgTypes+             _         -> "(,)" `con` (maybeHReturnType : hOutArgTypes)++mkForeignImport :: Text -> Callable -> Bool -> CodeGen ()+mkForeignImport symbol callable throwsGError = foreignImport $ do+    line first+    indent $ do+        mapM_ (\a -> line =<< fArgStr a) (args callable)+        when throwsGError $+               line $ padTo 40 "Ptr (Ptr GError) -> " ++ "-- error"+        line =<< last+    where+    first = "foreign import ccall \"" ++ T.unpack symbol ++ "\" " +++                T.unpack symbol ++ " :: "+    fArgStr arg = do+        ft <- foreignType $ argType arg+        weAlloc <- isJust <$> requiresAlloc (argType arg)+        let ft' = if direction arg == DirectionIn || weAlloc then+                      ft+                  else+                      ptr ft+        let start = show ft' ++ " -> "+        return $ padTo 40 start ++ "-- " ++ T.unpack (argName arg)+                   ++ " : " ++ show (argType arg)+    last = show <$> io <$> case returnType callable of+                             TBasicType TVoid -> return $ typeOf ()+                             _  -> foreignType (returnType callable)++-- Given an argument to a function, return whether it should be+-- wrapped in a maybe type (useful for nullable types). We do some+-- sanity checking to make sure that the argument is actually nullable+-- (a relatively common annotation mistake is to mix up (optional)+-- with (nullable)).+wrapMaybe :: Arg -> ExcCodeGen Bool+wrapMaybe arg =+    if mayBeNull arg+    then case argType arg of+           -- NULL GLists and GSLists are semantically the same as an+           -- empty list, so they don't need a Maybe wrapper on their+           -- type.+           TGList _ -> return False+           TGSList _ -> return False+           _ -> if isNullable (argType arg)+                then return True+                else badIntroError $ "argument \"" ++ T.unpack (argName arg) ++ "\" is not of nullable type, but it is marked as such."+    else return False++-- Given the list of arguments returns the list of constraints and the+-- list of types in the signature.+inArgInterfaces :: [Arg] -> ExcCodeGen ([String], [String])+inArgInterfaces inArgs = consAndTypes (['a'..'z'] \\ ['m']) inArgs+  where+    consAndTypes :: [Char] -> [Arg] -> ExcCodeGen ([String], [String])+    consAndTypes _ [] = return ([], [])+    consAndTypes letters (arg:args) = do+      (ls, t, cons) <- argumentType letters $ argType arg+      t' <- wrapMaybe arg >>= bool (return t)+                                   (return $ "Maybe (" ++ t ++ ")")+      (restCons, restTypes) <- consAndTypes ls args+      return (cons ++ restCons, t' : restTypes)++-- Given a callable, return a list of (array, length) pairs, where in+-- each pair "length" is the argument holding the length of the+-- (non-zero-terminated, non-fixed size) C array.+arrayLengthsMap :: Callable -> [(Arg, Arg)] -- List of (array, length)+arrayLengthsMap callable = go (args callable) []+    where+      go :: [Arg] -> [(Arg, Arg)] -> [(Arg, Arg)]+      go [] acc = acc+      go (a:as) acc = case argType a of+                        TCArray False fixedSize length _ ->+                            if fixedSize > -1 || length == -1+                            then go as acc+                            else go as $ (a, (args callable)!!length) : acc+                        _ -> go as acc++-- Return the list of arguments of the callable that contain length+-- arguments, including a possible length for the result of calling+-- the function.+arrayLengths :: Callable -> [Arg]+arrayLengths callable = map snd (arrayLengthsMap callable) +++               -- Often one of the arguments is just the length of+               -- the result.+               case returnType callable of+                 TCArray False (-1) length _ ->+                     if length > -1+                     then [(args callable)!!length]+                     else []+                 _ -> []++-- This goes through a list of [(a,b)], and tags every entry where the+-- "b" field has occurred before with the value of "a" for which it+-- occurred. (The first appearance is not tagged.)+classifyDuplicates :: Ord b => [(a, b)] -> [(a, b, Maybe a)]+classifyDuplicates args = doClassify Map.empty args+    where doClassify :: Ord b => Map.Map b a -> [(a, b)] -> [(a, b, Maybe a)]+          doClassify _ [] = []+          doClassify found ((value, key):args) =+              (value, key, Map.lookup key found) :+                doClassify (Map.insert key value found) args++-- Read the length of in array arguments from the corresponding+-- Haskell objects. A subtlety is that sometimes a single length+-- argument is expected from the C side to encode the length of+-- various lists. Ideally we would encode this in the types, but the+-- resulting API would be rather cumbersome. We insted perform runtime+-- checks to make sure that the given lists have the same length.+readInArrayLengths :: Name -> Callable -> [Arg] -> ExcCodeGen ()+readInArrayLengths name callable hInArgs = do+  let lengthMaps = classifyDuplicates $ arrayLengthsMap callable+  forM_ lengthMaps $ \(array, length, duplicate) ->+      when (array `elem` hInArgs) $+        case duplicate of+        Nothing -> readInArrayLength array length+        Just previous -> checkInArrayLength name array length previous++-- Read the length of an array into the corresponding variable.+readInArrayLength :: Arg -> Arg -> ExcCodeGen ()+readInArrayLength array length = do+  let lvar = escapeReserved $ argName length+      avar = escapeReserved $ argName array+  wrapMaybe array >>= bool+                (do+                  al <- computeArrayLength avar (argType array)+                  line $ "let " ++ lvar ++ " = " ++ al)+                (do+                  line $ "let " ++ lvar ++ " = case " ++ avar ++ " of"+                  indent $ indent $ do+                    line $ "Nothing -> 0"+                    let jarray = "j" ++ ucFirst avar+                    al <- computeArrayLength jarray (argType array)+                    line $ "Just " ++ jarray ++ " -> " ++ al)++-- Check that the given array has a length equal to the given length+-- variable.+checkInArrayLength :: Name -> Arg -> Arg -> Arg -> ExcCodeGen ()+checkInArrayLength n array length previous = do+  name <- lowerName n+  let funcName = namespace n ++ "." ++ name+      lvar = escapeReserved $ argName length+      avar = escapeReserved $ argName array+      expectedLength = avar ++ "_expected_length_"+      pvar = escapeReserved $ argName previous+  wrapMaybe array >>= bool+            (do+              al <- computeArrayLength avar (argType array)+              line $ "let " ++ expectedLength ++ " = " ++ al)+            (do+              line $ "let " ++ expectedLength ++ " = case " ++ avar ++ " of"+              indent $ indent $ do+                line $ "Nothing -> 0"+                let jarray = "j" ++ ucFirst avar+                al <- computeArrayLength jarray (argType array)+                line $ "Just " ++ jarray ++ " -> " ++ al)+  line $ "when (" ++ expectedLength ++ " /= " ++ lvar ++ ") $"+  indent $ line $ "error \"" ++ funcName ++ " : length of '" ++ avar +++             "' does not agree with that of '" ++ pvar ++ "'.\""++-- Whether to skip the return value in the generated bindings. The+-- C convention is that functions throwing an error and returning+-- a gboolean set the boolean to TRUE iff there is no error, so+-- the information is always implicit in whether we emit an+-- exception or not, so the return value can be omitted from the+-- generated bindings without loss of information (and omitting it+-- gives rise to a nicer API). See+-- https://bugzilla.gnome.org/show_bug.cgi?id=649657+skipRetVal :: Callable -> Bool -> Bool+skipRetVal callable throwsGError =+    (skipReturn callable) ||+         (throwsGError && returnType callable == TBasicType TBoolean)++freeInArgs' :: (Arg -> String -> String -> ExcCodeGen [String]) ->+               Callable -> Map.Map String String -> ExcCodeGen [String]+freeInArgs' freeFn callable nameMap = concat <$> actions+    where+      actions :: ExcCodeGen [[String]]+      actions = forM (args callable) $ \arg ->+        case Map.lookup (escapeReserved $ argName arg) nameMap of+          Just name -> freeFn arg name $+                       -- Pass in the length argument in case it's needed.+                       case argType arg of+                         TCArray False (-1) (-1) _ -> undefined+                         TCArray False (-1) length _ ->+                             escapeReserved $ argName $ (args callable)!!length+                         _ -> undefined+          Nothing -> badIntroError $ "freeInArgs: do not understand " ++ show arg++-- Return the list of actions freeing the memory associated with the+-- callable variables. This is run if the call to the C function+-- succeeds, if there is an error freeInArgsOnError below is called+-- instead.+freeInArgs = freeInArgs' freeInArg++-- Return the list of actions freeing the memory associated with the+-- callable variables. This is run in case there is an error during+-- the call.+freeInArgsOnError = freeInArgs' freeInArgOnError++-- Marshall the haskell arguments into their corresponding C+-- equivalents. omitted gives a list of DirectionIn arguments that+-- should be ignored, as they will be dealt with separately.+prepareArgForCall :: [Arg] -> Arg -> ExcCodeGen String+prepareArgForCall omitted arg = do+  isCallback <- findAPI (argType arg) >>=+                \case Just (APICallback _) -> return True+                      _ -> return False+  when (isCallback && direction arg /= DirectionIn) $+       notImplementedError "Only callbacks with DirectionIn are supported"++  case direction arg of+    DirectionIn -> if arg `elem` omitted+                   then return . escapeReserved . argName $ arg+                   else if isCallback+                        then prepareInCallback arg+                        else prepareInArg arg+    DirectionInout -> prepareInoutArg arg+    DirectionOut -> prepareOutArg arg++prepareInArg :: Arg -> ExcCodeGen String+prepareInArg arg = do+  let name = escapeReserved $ argName arg+  wrapMaybe arg >>= bool+            (convert name $ hToF (argType arg) (transfer arg))+            (do+              let maybeName = "maybe" ++ ucFirst name+              line $ maybeName ++ " <- case " ++ name ++ " of"+              indent $ do+                line $ "Nothing -> return nullPtr"+                let jName = "j" ++ ucFirst name+                line $ "Just " ++ jName ++ " -> do"+                indent $ do+                         converted <- convert jName $ hToF (argType arg)+                                                           (transfer arg)+                         line $ "return " ++ converted+                return maybeName)++-- Callbacks are a fairly special case, we treat them separately.+prepareInCallback :: Arg -> ExcCodeGen String+prepareInCallback arg = do+  let name = escapeReserved $ argName arg+      ptrName = "ptr" ++ name+      scope = argScope arg++  (maker, wrapper) <- case argType arg of+                        (TInterface ns n) ->+                            do+                              prefix <- qualify ns+                              return $ (prefix ++ "mk" ++ n,+                                        prefix ++ lcFirst n ++ "Wrapper")+                        _ -> error $ "prepareInCallback : Not an interface! " ++ ppShow arg++  fC <- tyConName <$> typeRepTyCon <$> foreignType (argType arg)++  when (scope == ScopeTypeAsync) $+       line $ ptrName ++ " <- callocBytes $ sizeOf (undefined :: " ++ fC ++ ")"+  wrapMaybe arg >>= bool+            (do+              let name' = prime name+                  p = if (scope == ScopeTypeAsync)+                      then parenthesize $ "Just " ++ ptrName+                      else "Nothing"+              line $ name' ++ " <- " ++ maker ++ " "+                       ++ parenthesize (wrapper ++ " " ++ p ++ " " ++ name)+              when (scope == ScopeTypeAsync) $+                   line $ "poke " ++ ptrName ++ " " ++ name'+              return name')+            (do+              let maybeName = "maybe" ++ ucFirst name+              line $ maybeName ++ " <- case " ++ name ++ " of"+              indent $ do+                line $ "Nothing -> return (castPtrToFunPtr nullPtr)"+                let jName = "j" ++ ucFirst name+                    jName' = prime jName+                line $ "Just " ++ jName ++ " -> do"+                indent $ do+                         let p = if (scope == ScopeTypeAsync)+                                 then parenthesize $ "Just " ++ ptrName+                                 else "Nothing"+                         line $ jName' ++ " <- " ++ maker ++ " "+                                  ++ parenthesize (wrapper ++ " "+                                                   ++ p ++ " " ++ jName)+                         when (scope == ScopeTypeAsync) $+                              line $ "poke " ++ ptrName ++ " " ++ jName'+                         line $ "return " ++ jName'+              return maybeName)++prepareInoutArg :: Arg -> ExcCodeGen String+prepareInoutArg arg = do+  name' <- prepareInArg arg+  ft <- foreignType $ argType arg+  allocInfo <- requiresAlloc (argType arg)+  case allocInfo of+    Just (isBoxed, n) -> do+         let allocator = if isBoxed+                         then "callocBoxedBytes"+                         else "callocBytes"+         wrapMaybe arg >>= bool+            (do+              name'' <- genConversion (prime name') $+                        literal $ M $ allocator ++ " " ++ show n +++                                    " :: " ++ show (io ft)+              line $ "memcpy " ++ name'' ++ " " ++ name' ++ " " ++ show n+              return name'')+             -- The semantics of this case are somewhat undefined.+            (notImplementedError "Nullable inout structs not supported")+    Nothing -> do+      name'' <- genConversion (prime name') $+                literal $ M $ "allocMem :: " ++ show (io $ ptr ft)+      line $ "poke " ++ name'' ++ " " ++ name'+      return name''++prepareOutArg :: Arg -> CodeGen String+prepareOutArg arg = do+  let name = escapeReserved $ argName arg+  ft <- foreignType $ argType arg+  allocInfo <- requiresAlloc (argType arg)+  case allocInfo of+    Just (isBoxed, n) -> do+        let allocator = if isBoxed+                        then "callocBoxedBytes"+                        else "callocBytes"+        genConversion name $ literal $ M $ allocator ++ " " ++ show n +++                                      " :: " ++ show (io ft)+    Nothing ->+        genConversion name $+                  literal $ M $ "allocMem :: " ++ show (io $ ptr ft)++-- Convert a non-zero terminated out array, stored in a variable+-- named "aname", into the corresponding Haskell object.+convertOutCArray :: Callable -> Type -> String -> Map.Map String String ->+                    Transfer -> ExcCodeGen String+convertOutCArray callable t@(TCArray False fixed length _) aname+                 nameMap transfer = do+  if fixed > -1+  then do+    unpacked <- convert aname $ unpackCArray (show fixed) t transfer+    -- Free the memory associated with the array+    freeContainerType transfer t aname undefined+    return unpacked+  else do+    when (length == -1) $+         badIntroError $ "Unknown length for \"" ++ aname ++ "\""+    let lname = escapeReserved $ argName $ (args callable)!!length+    lname' <- case Map.lookup lname nameMap of+                Just n -> return n+                Nothing ->+                    badIntroError $ "Couldn't find out array length " +++                                            lname+    let lname'' = prime lname'+    unpacked <- convert aname $ unpackCArray lname'' t transfer+    -- Free the memory associated with the array+    freeContainerType transfer t aname lname''+    return unpacked++-- Remove the warning, this should never be reached.+convertOutCArray _ t _ _ _ =+    error $ "convertOutCArray : unexpected " ++ show t++-- Read the array lengths for out arguments.+readOutArrayLengths :: Callable -> Map.Map String String -> ExcCodeGen ()+readOutArrayLengths callable nameMap = do+  let lNames = nub $ map (escapeReserved . argName) $+               filter ((/= DirectionIn) . direction) $+               arrayLengths callable+  forM_ lNames $ \lname -> do+    lname' <- case Map.lookup lname nameMap of+                   Just n -> return n+                   Nothing ->+                       badIntroError $ "Couldn't find out array length " +++                                               lname+    genConversion lname' $ apply $ M "peek"++-- Touch DirectionIn arguments so we are sure that they exist when the+-- C function was called.+touchInArg :: Arg -> ExcCodeGen ()+touchInArg arg = when (direction arg /= DirectionOut) $ do+  let name = escapeReserved $ argName arg+  case elementType (argType arg) of+    Just a -> do+      managed <- isManaged a+      when managed $ wrapMaybe arg >>= bool+              (line $ "mapM_ touchManagedPtr " ++ name)+              (line $ "whenJust " ++ name ++ " (mapM_ touchManagedPtr)")+    Nothing -> do+      managed <- isManaged (argType arg)+      when managed $ wrapMaybe arg >>= bool+           (line $ "touchManagedPtr " ++ name)+           (line $ "whenJust " ++ name ++ " touchManagedPtr")++-- Find the association between closure arguments and their+-- corresponding callback.+closureToCallbackMap :: Callable -> ExcCodeGen (Map.Map Int Arg)+closureToCallbackMap callable =+    -- The introspection info does not specify the closure for destroy+    -- notify's associated with a callback, since it is implicitly the+    -- same one as the ScopeTypeNotify callback associated with the+    -- DestroyNotify.+    go (filter (not . (`elem` destroyers)) $ args callable) Map.empty++    where destroyers = map (args callable!!) . filter (/= -1) . map argDestroy+                       $ args callable++          go :: [Arg] -> Map.Map Int Arg -> ExcCodeGen (Map.Map Int Arg)+          go [] m = return m+          go (arg:as) m =+              if argScope arg == ScopeTypeInvalid+              then go as m+              else case argClosure arg of+                  (-1) -> go as m+                  c -> case Map.lookup c m of+                      Just _ -> notImplementedError $+                                "Closure for multiple callbacks unsupported"+                                ++ ppShow arg ++ "\n"+                                ++ ppShow callable+                      Nothing -> go as $ Map.insert c arg m++-- user_data style arguments.+prepareClosures :: Callable -> Map.Map String String -> ExcCodeGen ()+prepareClosures callable nameMap = do+  m <- closureToCallbackMap callable+  let closures = filter (/= -1) . map argClosure $ args callable+  forM_ closures $ \closure ->+      case Map.lookup closure m of+        Nothing -> badIntroError $ "Closure not found! "+                                ++ ppShow callable+                                ++ "\n" ++ ppShow m+                                ++ "\n" ++ show closure+        Just cb -> do+          let closureName = escapeReserved $ argName $ (args callable)!!closure+              n = escapeReserved $ argName cb+          n' <- case Map.lookup n nameMap of+                  Just n -> return n+                  Nothing -> badIntroError $ "Cannot find closure name!! "+                                           ++ ppShow callable ++ "\n"+                                           ++ ppShow nameMap+          case argScope cb of+            ScopeTypeInvalid -> badIntroError $ "Invalid scope! "+                                              ++ ppShow callable+            ScopeTypeNotified -> do+                line $ "let " ++ closureName ++ " = castFunPtrToPtr " ++ n'+                case argDestroy cb of+                  (-1) -> badIntroError $+                          "ScopeTypeNotified without destructor! "+                           ++ ppShow callable+                  k -> let destroyName =+                            escapeReserved . argName $ (args callable)!!k in+                       line $ "let " ++ destroyName ++ " = safeFreeFunPtrPtr"+            ScopeTypeAsync ->+                line $ "let " ++ closureName ++ " = nullPtr"+            ScopeTypeCall -> line $ "let " ++ closureName ++ " = nullPtr"++freeCallCallbacks :: Callable -> Map.Map String String -> ExcCodeGen ()+freeCallCallbacks callable nameMap =+    forM_ (args callable) $ \arg -> do+       let name = escapeReserved $ argName arg+       name' <- case Map.lookup name nameMap of+                  Just n -> return n+                  Nothing -> badIntroError $ "Could not find " ++ name+                                ++ " in " ++ ppShow callable ++ "\n"+                                ++ ppShow nameMap+       when (argScope arg == ScopeTypeCall) $+            line $ "safeFreeFunPtr $ castFunPtrToPtr " ++ name'++hSignature :: [Arg] -> TypeRep -> ExcCodeGen ()+hSignature hInArgs retType = do+  (argConstraints, types) <- inArgInterfaces hInArgs+  indent $ do+      line $ "(" ++ intercalate ", " ("MonadIO m" : argConstraints) ++ ") =>"+      forM_ (zip types hInArgs) $ \(t, a) ->+           line $ withComment (t ++ " ->") $ T.unpack (argName a)+      line . show $ "m" `con` [retType]++genCallable :: Name -> Text -> Callable -> Bool -> ExcCodeGen ()+genCallable n symbol callable throwsGError = do+    group $ do+        line $ "-- Args : " ++ (show $ args callable)+        line $ "-- Lengths : " ++ (show $ arrayLengths callable)+        line $ "-- hInArgs : " ++ show hInArgs+        line $ "-- returnType : " ++ (show $ returnType callable)+        line $ "-- throws : " ++ (show throwsGError)+        line $ "-- Skip return : " ++ (show $ skipReturn callable)+        when (skipReturn callable && returnType callable /= TBasicType TBoolean) $+             do line "-- XXX return value ignored, but it is not a boolean."+                line "--     This may be a memory leak?"+    mkForeignImport symbol callable throwsGError+    blank+    wrapper++    where+    inArgs = filter ((/= DirectionOut) . direction) $ args callable+    -- We do not expose user_data arguments, destroynotify arguments,+    -- and C array length arguments to Haskell code.+    closures = map (args callable!!) . filter (/= -1) . map argClosure $ inArgs+    destroyers = map (args callable!!) . filter (/= -1) . map argDestroy $ inArgs+    omitted = arrayLengths callable ++ closures ++ destroyers+    hInArgs = filter (`notElem` omitted) inArgs+    outArgs = filter ((/= DirectionIn) . direction) $ args callable+    hOutArgs = filter (`notElem` (arrayLengths callable)) outArgs++    ignoreReturn = skipRetVal callable throwsGError++    wrapper = group $ do+        let argName' = escapeReserved . argName+        name <- lowerName n+        line $ deprecatedPragma name $ callableDeprecated callable+        line $ name ++ " ::"+        hSignature hInArgs =<< hOutType callable hOutArgs ignoreReturn+        line $ name ++ " " ++ intercalate " " (map argName' hInArgs) ++ " = liftIO $ do"+        indent $ do+            readInArrayLengths n callable hInArgs+            inArgNames <- forM (args callable) $ \arg ->+                          prepareArgForCall omitted arg+            -- Map from argument names to names passed to the C function+            let nameMap = Map.fromList $ flip zip inArgNames+                                               $ map argName' $ args callable+            prepareClosures callable nameMap+            if throwsGError+            then do+                line "onException (do"+                indent $ do+                    invokeCFunction inArgNames+                    readOutArrayLengths callable nameMap+                    result <- convertResult nameMap+                    pps <- convertOut nameMap+                    freeCallCallbacks callable nameMap+                    forM_ (args callable) touchInArg+                    mapM_ line =<< freeInArgs callable nameMap+                    returnResult result pps+                line " ) (do"+                indent $ do+                    freeCallCallbacks callable nameMap+                    actions <- freeInArgsOnError callable nameMap+                    case actions of+                        [] -> line $ "return ()"+                        _ -> mapM_ line actions+                line " )"+            else do+                invokeCFunction inArgNames+                readOutArrayLengths callable nameMap+                result <- convertResult nameMap+                pps <- convertOut nameMap+                freeCallCallbacks callable nameMap+                forM_ (args callable) touchInArg+                mapM_ line =<< freeInArgs callable nameMap+                returnResult result pps++    invokeCFunction argNames = do+        let returnBind = case returnType callable of+                           TBasicType TVoid -> ""+                           _                -> if ignoreReturn+                                               then "_ <- "+                                               else "result <- "+            maybeCatchGErrors = if throwsGError+                                then "propagateGError $ "+                                else ""+        line $ returnBind ++ maybeCatchGErrors+                 ++ T.unpack symbol ++ concatMap (" " ++) argNames++    convertResult :: Map.Map String String -> ExcCodeGen String+    convertResult nameMap =+        if ignoreReturn || returnType callable == TBasicType TVoid+        then return undefined+        else do+            if returnMayBeNull callable+            then do+                line $ "maybeResult <- convertIfNonNull result $ \\result' -> do"+                indent $ do+                    converted <- unwrappedConvertResult "result'"+                    line $ "return " ++ converted+                return "maybeResult"+            else unwrappedConvertResult "result"++        where+        unwrappedConvertResult rname = case returnType callable of+            -- Arrays without length information are just passed+            -- along.+            TCArray False (-1) (-1) _ -> return rname+            -- Not zero-terminated C arrays require knowledge of the+            -- length, so we deal with them directly.+            t@(TCArray False _ _ _) ->+                convertOutCArray callable t rname nameMap+                                 (returnTransfer callable)+            t -> do+                result <- convert rname $ fToH (returnType callable)+                                               (returnTransfer callable)+                freeContainerType (returnTransfer callable) t rname undefined+                return result++    convertOut :: Map.Map String String -> ExcCodeGen [String]+    convertOut nameMap = do+        -- Convert out parameters and result+        forM hOutArgs $ \arg -> do+            let name = escapeReserved $ argName arg+            inName <- case Map.lookup name nameMap of+                Just name' -> return name'+                Nothing -> badIntroError $ "Parameter " ++ name ++ " not found!"+            case argType arg of+                -- Passed along as a raw pointer+                TCArray False (-1) (-1) _ -> genConversion inName $ apply $ M "peek"+                t@(TCArray False _ _ _) -> do+                    aname' <- genConversion inName $ apply $ M "peek"+                    let wrapArray a = convertOutCArray callable t a+                                          nameMap (transfer arg)+                    wrapMaybe arg >>= bool+                           (wrapArray aname')+                           (do line $ "maybe" ++ ucFirst aname'+                                   ++ " <- convertIfNonNull " ++ aname'+                                   ++ " $ \\" ++ prime aname' ++ " -> do"+                               indent $ do+                                   wrapped <- wrapArray (prime aname')+                                   line $ "return " ++ wrapped+                               return $ "maybe" ++ ucFirst aname')+                t -> do+                    weAlloc <- isJust <$> requiresAlloc t+                    peeked <- if weAlloc+                             then return inName+                             else genConversion inName $ apply $ M "peek"+                    -- If we alloc we always take control of the resulting+                    -- memory, otherwise we may leak.+                    let transfer' = if weAlloc+                                   then TransferEverything+                                   else transfer arg+                    result <- do+                        let wrap ptr = convert ptr $ fToH (argType arg) transfer'+                        wrapMaybe arg >>= bool+                            (wrap peeked)+                            (do line $ "maybe" ++ ucFirst peeked+                                    ++ " <- convertIfNonNull " ++ peeked+                                    ++ " $ \\" ++ prime peeked ++ " -> do"+                                indent $ do+                                    wrapped <- wrap (prime peeked)+                                    line $ "return " ++ wrapped+                                return $ "maybe" ++ ucFirst peeked)+                    -- Free the memory associated with the out argument+                    freeContainerType transfer' t peeked undefined+                    return result++    returnResult :: String -> [String] -> CodeGen ()+    returnResult result pps =+        if ignoreReturn || returnType callable == TBasicType TVoid+        then case pps of+            []      -> line "return ()"+            (pp:[]) -> line $ "return " ++ pp+            _       -> line $ "return (" ++ intercalate ", " pps ++ ")"+        else case pps of+            [] -> line $ "return " ++ result+            _  -> line $ "return (" ++ intercalate ", " (result : pps) ++ ")"
+ src/GI/Code.hs view
@@ -0,0 +1,249 @@+module GI.Code+    ( Code(..)+    , BaseCodeGen+    , CodeGen+    , ExcCodeGen+    , CGError(..)+    , genCode+    , evalCodeGen+    , codeToString+    , loadDependency+    , getDeps+    , recurse+    , recurse'+    , handleCGExc+    , describeCGError+    , notImplementedError+    , badIntroError+    , missingInfoError+    , indent+    , line+    , blank+    , group+    , foreignImport++    , findAPI+    , findAPIByName+    , getAPIs+    , injectAPIs++    , config+    ) where++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative ((<$>))+#endif+import Control.Monad.RWS+import Control.Monad.Except+import Data.Sequence (Seq, ViewL ((:<)), (><), (|>), (<|))+import qualified Data.Map as M+import qualified Data.Sequence as S+import qualified Data.Set as Set++import GI.API (API, Name(..))+import GI.Config (Config(..))+import GI.Type (Type(..))++data Code+    = NoCode+    | Line String+    | Indent Code+    | Sequence (Seq Code)+    | ForeignImport Code+    | Group Code+    deriving (Eq, Show)++instance Monoid Code where+    mempty = NoCode++    NoCode `mappend` NoCode = NoCode+    x `mappend` NoCode = x+    NoCode `mappend` x = x+    (Sequence a) `mappend` (Sequence b) = Sequence (a >< b)+    (Sequence a) `mappend` b = Sequence (a |> b)+    a `mappend` (Sequence b) = Sequence (a <| b)+    a `mappend` b = Sequence (a <| b <| S.empty)++type Deps = Set.Set String+data CodeGenState = CodeGenState {+      moduleDeps :: Deps,+      loadedAPIs :: M.Map Name API }++data CGError = CGErrorNotImplemented String+             | CGErrorBadIntrospectionInfo String+             | CGErrorMissingInfo String+               deriving (Show)++type BaseCodeGen excType a =+    RWST Config Code CodeGenState (ExceptT excType IO) a++-- | The code generator monad, for generators that cannot throw+-- errors. The fact that they cannot throw errors is encoded in the+-- forall, which disallows any operation on the error, except+-- discarding it or passing it along without inspecting. This last+-- operation is useful in order to allow embedding `CodeGen`+-- computations inside `ExcCodeGen` computations, while disallowing+-- the opposite embedding without explicit error handling.+type CodeGen a = forall e. BaseCodeGen e a++-- | Code generators that can throw errors.+type ExcCodeGen a = BaseCodeGen CGError a++-- | Due to the `forall` in the definition of `CodeGen`, if we want to+-- run the monad transformer stack until we get an `IO` action, our+-- only option is ignoring the possible error code from+-- `runExceptT`. This is perfectly safe, since there is no way to+-- construct a computation in the `CodeGen` monad that throws an+-- exception, due to the higher rank type.+unwrapCodeGen :: Config -> CodeGenState -> CodeGen a ->+                 IO (a, CodeGenState, Code)+unwrapCodeGen cfg state cg =+    runExceptT (runRWST cg cfg state) >>= \case+        Left _ -> error "unwrapCodeGen:: The impossible happened!"+        Right (r, s, c) -> return (r, s, c)++-- | Run the given code generator, merging its resulting state into+-- the ambient state, and turning its output into a value.+recurse :: BaseCodeGen e a -> BaseCodeGen e (a, Code)+recurse cg = do+    r <- ask+    oldState <- get+    liftIO (runExceptT $ runRWST cg r oldState) >>= \case+        Left e -> throwError e+        Right (r, st, c) -> put (mergeState oldState st) >> return (r, c)++-- | Try running the given `action`, and if it fails run `fallback`+-- instead.+handleCGExc :: (CGError -> CodeGen a) -> ExcCodeGen a -> CodeGen a+handleCGExc fallback action = do+    r <- ask+    oldState <- get+    liftIO (runExceptT $ runRWST action r oldState) >>= \case+        Left e -> fallback e+        Right (r, s, c) -> do+            put $ mergeState oldState s+            tell c+            return r++emptyState :: CodeGenState+emptyState = CodeGenState {moduleDeps = Set.empty+                          ,loadedAPIs = M.empty }++getDeps :: CodeGen Deps+getDeps = moduleDeps <$> get++getAPIs :: CodeGen (M.Map Name API)+getAPIs = loadedAPIs <$> get++-- | Inject the given APIs into loaded set.+injectAPIs :: [(Name, API)] -> CodeGen()+injectAPIs newAPIs = do+  oldState <- get+  put $ oldState {loadedAPIs =+                      M.union (loadedAPIs oldState) (M.fromList newAPIs)}++-- | Merge two states of a code generator.+mergeState :: CodeGenState -> CodeGenState -> CodeGenState+mergeState oldState newState =+    -- If no dependencies were added we do not need to merge.+    if Set.size (moduleDeps oldState) /= Set.size (moduleDeps newState)+    then let newDeps = Set.union (moduleDeps oldState) (moduleDeps newState)+             newAPIs = M.union (loadedAPIs oldState) (loadedAPIs newState)+         in CodeGenState {moduleDeps = newDeps, loadedAPIs = newAPIs}+    else oldState++-- | Run a code generator, and return the dependencies encountered+-- when generating code.+genCode :: Config -> M.Map Name API -> CodeGen () -> IO (Deps, Code)+genCode cfg apis cg = do+    (_, st, code) <- unwrapCodeGen cfg (emptyState {loadedAPIs = apis}) cg+    return (moduleDeps st, code)++-- | Like `genCode`, but keep the final value and output, discarding+-- the state.+evalCodeGen :: Config -> M.Map Name API -> CodeGen a -> IO (a, Code)+evalCodeGen cfg apis cg = do+  (r, _, code) <- unwrapCodeGen cfg (emptyState {loadedAPIs = apis}) cg+  return (r, code)++-- | Like `recurse`, but for generators returning a unit value, where+-- we can just drop the result.+recurse' :: CodeGen () -> CodeGen Code+recurse' cg = snd <$> recurse cg++-- | Mark the given dependency as used by the module.+loadDependency :: String -> CodeGen ()+loadDependency name = do+    deps <- getDeps+    unless (Set.member name deps) $ do+        let newDeps = Set.insert name deps+        modify' $ \s -> s {moduleDeps = newDeps}++-- | Give a friendly textual description of the error for presenting+-- to the user.+describeCGError :: CGError -> String+describeCGError (CGErrorNotImplemented e) = "Not implemented: " ++ show e+describeCGError (CGErrorBadIntrospectionInfo e) = "Bad introspection data: " ++ show e+describeCGError (CGErrorMissingInfo e) = "Missing info: " ++ show e++notImplementedError :: String -> ExcCodeGen a+notImplementedError s = throwError $ CGErrorNotImplemented s++badIntroError :: String -> ExcCodeGen a+badIntroError s = throwError $ CGErrorBadIntrospectionInfo s++missingInfoError :: String -> ExcCodeGen a+missingInfoError s = throwError $ CGErrorMissingInfo s++findAPI :: Type -> CodeGen (Maybe API)+findAPI TError = Just <$> findAPIByName (Name "GLib" "Error")+findAPI (TInterface ns n) = Just <$> findAPIByName (Name ns n)+findAPI _ = return Nothing++findAPIByName :: Name -> CodeGen API+findAPIByName n@(Name ns _) = do+    apis <- getAPIs+    case M.lookup n apis of+        Just api -> return api+        Nothing ->+            error $ "couldn't find API description for " ++ ns ++ "." ++ name n++config :: CodeGen Config+config = ask++line :: String -> CodeGen ()+line = tell . Line++blank :: CodeGen ()+blank = line ""++indent :: BaseCodeGen e a -> BaseCodeGen e a+indent cg = do+  (x, code) <- recurse cg+  tell $ Indent code+  return x++group :: BaseCodeGen e a -> BaseCodeGen e a+group cg = do+  (x, code) <- recurse cg+  tell $ Group code+  blank+  return x++foreignImport :: BaseCodeGen e a -> BaseCodeGen e a+foreignImport cg = do+  (a, c) <- recurse cg+  tell $ ForeignImport c+  return a++codeToString c = unlines $ str 0 c []+    where str _ NoCode cont = cont+          str n (Line s) cont = (replicate (n * 4) ' ' ++ s) : cont+          str n (Indent c) cont = str (n + 1) c cont+          str n (ForeignImport c) cont = str n c cont+          str n (Sequence s) cont = deseq n (S.viewl s) cont+          -- str n (Sequence s) cont = F.foldr (\code rest -> str n code : rest) cont s+          str n (Group c) cont = str n c cont++          deseq _ S.EmptyL cont = cont+          deseq n (c :< cs) cont = str n c (deseq n (S.viewl cs) cont)
+ src/GI/Config.hs view
@@ -0,0 +1,14 @@+module GI.Config+    ( Config(..)+    ) where++import GI.Overrides (Overrides)++data Config = Config {+      -- | Name of the module being generated.+      modName        :: Maybe String,+      -- | Whether to print extra info.+      verbose        :: Bool,+      -- | List of loaded overrides for the code generator.+      overrides      :: Overrides+    }
+ src/GI/Constant.hs view
@@ -0,0 +1,71 @@+module GI.Constant+    ( genConstant+    ) where++import qualified Data.Text as T+import Data.Text (Text)++import GI.API+import GI.Code+import GI.Conversions+import GI.Type++genConstant :: Name -> Constant -> CodeGen ()+genConstant (Name _ name) (Constant t value deprecated) = do+  line $ "-- constant " ++ name+  line $ deprecatedPragma name deprecated++  handleCGExc (\e -> line $ "-- XXX: Could not generate constant: " ++ describeCGError e)+              (assignValue name t value)++-- | Assign to the given name the given constant value, in a way that+-- can be assigned to the corresponding Haskell type.+assignValue :: String -> Type -> Text -> ExcCodeGen ()+assignValue name t@(TBasicType b) value = do+  ht <- haskellType t+  line $ name ++ " :: " ++ show ht+  hv <- showBasicType b value+  line $ name ++ " = " ++ hv+assignValue name t@(TInterface _ _) value = do+  ht <- haskellType t+  api <- findAPI t+  case api of+    Just (APIEnum _) -> do+             line $ name ++ " :: " ++ show ht+             line $ name ++ " = toEnum " ++ T.unpack value+    Just (APIFlags _) -> do+             line $ name ++ " :: " ++ show ht+             line $ name ++ " = wordToGFlags " ++ T.unpack value+    Just (APIStruct s) | structIsBoxed s == False -> do+             line $ name ++ " :: IO " ++ show ht+             line $ name ++ " = do"+             indent $ do+               line $ "let ptr = intPtrToPtr " ++ T.unpack value+               wrapped <- convert "ptr" (fToH t TransferNothing)+               line $ "return " ++ wrapped+    _ -> notImplementedError $ "Don't know how to treat constants of type " ++ show t+assignValue _ t _ = notImplementedError $ "Don't know how to treat constants of type " ++ show t++-- | Show a basic type, in a way that can be assigned to the+-- corresponding Haskell type.+showBasicType                  :: BasicType -> Text -> ExcCodeGen String+showBasicType TInt8    i       = return $ T.unpack i+showBasicType TUInt8   i       = return $ T.unpack i+showBasicType TInt16   i       = return $ T.unpack i+showBasicType TUInt16  i       = return $ T.unpack i+showBasicType TInt32   i       = return $ T.unpack i+showBasicType TUInt32  i       = return $ T.unpack i+showBasicType TInt64   i       = return $ T.unpack i+showBasicType TUInt64  i       = return $ T.unpack i+showBasicType TBoolean "0"     = return "False"+showBasicType TBoolean "false" = return "False"+showBasicType TBoolean "1"     = return "True"+showBasicType TBoolean "true"  = return "True"+showBasicType TBoolean b       = notImplementedError $ "Could not parse boolean \"" ++ T.unpack b ++ "\""+showBasicType TFloat   f       = return $ T.unpack f+showBasicType TDouble  d       = return $ T.unpack d+showBasicType TUTF8    s       = return $ show s+showBasicType TFileName fn     = return $ show fn+showBasicType TUniChar c       = return $ "'" ++ T.unpack c ++ "'"+showBasicType TVoid    ptr     = return $ "intPtrToPtr " ++ T.unpack ptr+showBasicType TGType   gtype   = return $ "GType " ++ T.unpack gtype
+ src/GI/Conversions.hs view
@@ -0,0 +1,772 @@+{-# LANGUAGE PatternGuards, DeriveFunctor #-}++module GI.Conversions+    ( convert+    , genConversion+    , unpackCArray+    , computeArrayLength++    , hToF+    , fToH+    , haskellType+    , foreignType++    , argumentType+    , elementType+    , elementMap+    , elementTypeAndMap++    , isManaged+    , isNullable++    , getIsScalar+    , requiresAlloc++    , apply+    , mapC+    , literal+    , Constructor(..)+    ) where++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative ((<$>))+#endif+import Control.Monad (when)+import Control.Monad.Free (Free(..), liftF)+import Data.List (intercalate)+import Data.Typeable (TypeRep, tyConName, typeRepTyCon, typeOf)+import Data.Int+import qualified Data.Text as T+import Data.Word+import GHC.Exts (IsString(..))++import GI.API+import GI.Code+import GI.GObject+import GI.SymbolNaming+import GI.Type+import GI.Util++-- String identifying a constructor in the generated code, which is+-- either (by default) a pure function (indicated by the P+-- constructor) or a function returning values on a monad (M+-- constructor). 'Id' denotes the identity function.+data Constructor = P String | M String | Id+                   deriving (Eq,Show)+instance IsString Constructor where+    fromString = P++data FExpr next = Apply Constructor next+                | MapC Map Constructor next+                | Literal Constructor next+                  deriving (Show, Functor)++type Converter = Free FExpr ()++-- Different available maps.+data Map = Map | MapFirst | MapSecond+         deriving (Show)++-- Naming for the maps.+mapName :: Map -> String+mapName Map = "map"+mapName MapFirst = "mapFirst"+mapName MapSecond = "mapSecond"++-- Naming for the monadic versions of the maps that we use+monadicMapName :: Map -> String+monadicMapName Map = "mapM"+monadicMapName MapFirst = "mapFirstA"+monadicMapName MapSecond = "mapSecondA"++apply :: Constructor -> Converter+apply f = liftF $ Apply f ()++mapC :: Constructor -> Converter+mapC f = liftF $ MapC Map f ()++mapFirst :: Constructor -> Converter+mapFirst f = liftF $ MapC MapFirst f ()++mapSecond :: Constructor -> Converter+mapSecond f = liftF $ MapC MapSecond f ()++literal :: Constructor -> Converter+literal f = liftF $ Literal f ()++genConversion :: String -> Converter -> CodeGen String+genConversion l (Pure ()) = return l+genConversion l (Free k) = do+  let l' = prime l+  case k of+    Apply (P f) next ->+        do line $ "let " ++ l' ++ " = " ++ f ++ " " ++ l+           genConversion l' next+    Apply (M f) next ->+        do line $ l' ++ " <- " ++ f ++ " " ++ l+           genConversion l' next+    Apply Id next -> genConversion l next++    MapC m (P f) next ->+        do line $ "let " ++ l' ++ " = " ++ mapName m ++ " " ++ f ++ " " ++ l+           genConversion l' next+    MapC m (M f) next ->+        do line $ l' ++ " <- " ++ monadicMapName m ++ " " ++ f ++ " " ++ l+           genConversion l' next+    MapC _ Id next -> genConversion l next++    Literal (P f) next ->+        do line $ "let " ++ l ++ " = " ++ f+           genConversion l next+    Literal (M f) next ->+        do line $ l ++ " <- " ++ f+           genConversion l next+    Literal Id next -> genConversion l next++-- Given an array, together with its type, return the code for reading+-- its length.+computeArrayLength :: String -> Type -> ExcCodeGen String+computeArrayLength array (TCArray _ _ _ t) = do+  reader <- findReader+  return $ "fromIntegral $ " ++ reader ++ " " ++ array+    where findReader = case t of+                     TBasicType TUInt8 -> return "B.length"+                     TBasicType _      -> return "length"+                     TInterface _ _    -> return "length"+                     TCArray{}         -> return "length"+                     _ -> notImplementedError $+                          "Don't know how to compute length of " ++ show t+computeArrayLength _ t =+    notImplementedError $ "computeArrayLength called on non-CArray type "+                            ++ show t++convert :: String -> BaseCodeGen e Converter -> BaseCodeGen e String+convert l c = do+  c' <- c+  genConversion l c'++hObjectToF :: Type -> Transfer -> ExcCodeGen Constructor+hObjectToF t transfer =+  if transfer == TransferEverything+  then do+    isGO <- isGObject t+    if isGO+    then return $ M "refObject"+    else badIntroError "Transferring a non-GObject object"+  -- castPtr since we accept any instance of the class associated with+  -- the GObject, not just the precise type of the GObject, while the+  -- foreign function declaration requires a pointer of the precise+  -- type.+  else return "unsafeManagedPtrCastPtr"++hVariantToF :: Transfer -> CodeGen Constructor+hVariantToF transfer =+  if transfer == TransferEverything+  then return $ M "refGVariant"+  else return "unsafeManagedPtrGetPtr"++hParamSpecToF :: Transfer -> CodeGen Constructor+hParamSpecToF transfer =+  if transfer == TransferEverything+  then return $ M "refGParamSpec"+  else return "unsafeManagedPtrGetPtr"++hBoxedToF :: Transfer -> CodeGen Constructor+hBoxedToF transfer =+  if transfer == TransferEverything+  then return $ M "copyBoxed"+  else return "unsafeManagedPtrGetPtr"++hStructToF :: Struct -> Transfer -> ExcCodeGen Constructor+hStructToF s transfer =+    if transfer /= TransferEverything || structIsBoxed s then+        hBoxedToF transfer+    else do+        when (structSize s == 0) $+             badIntroError "Transferring a non-boxed struct with unknown size!"+        return "unsafeManagedPtrGetPtr"++hUnionToF :: Union -> Transfer -> ExcCodeGen Constructor+hUnionToF u transfer =+    if transfer /= TransferEverything || unionIsBoxed u then+        hBoxedToF transfer+    else do+        when (unionSize u == 0) $+             badIntroError "Transferring a non-boxed union with unknown size!"+        return "unsafeManagedPtrGetPtr"++-- Given the Haskell and Foreign types, returns the name of the+-- function marshalling between both.+hToF' :: Type -> Maybe API -> TypeRep -> TypeRep -> Transfer+            -> ExcCodeGen Constructor+hToF' t a hType fType transfer+    | ( hType == fType ) = return Id+    | TError <- t = hBoxedToF transfer+    | TVariant <- t = hVariantToF transfer+    | TParamSpec <- t = hParamSpecToF transfer+    | Just (APIEnum _) <- a = return "(fromIntegral . fromEnum)"+    | Just (APIFlags _) <- a = return "gflagsToWord"+    | Just (APIObject _) <- a = hObjectToF t transfer+    | Just (APIInterface _) <- a = hObjectToF t transfer+    | Just (APIStruct s) <- a = hStructToF s transfer+    | Just (APIUnion u) <- a = hUnionToF u transfer+    -- Converting callback types requires more context, we leave that+    -- as a special case to be implemented by the caller.+    | Just (APICallback _) <- a = error "Cannot handle callback type here!! "+    | TByteArray <- t = return $ M "packGByteArray"+    | TCArray True _ _ (TBasicType TUTF8) <- t =+        return $ M "packZeroTerminatedUTF8CArray"+    | TCArray True _ _ (TBasicType TFileName) <- t =+        return $ M "packZeroTerminatedFileNameArray"+    | TCArray True _ _ (TBasicType TVoid) <- t =+        return $ M "packZeroTerminatedPtrArray"+    | TCArray True _ _ (TBasicType TUInt8) <- t =+        return $ M "packZeroTerminatedByteString"+    | TCArray True _ _ (TBasicType TBoolean) <- t =+        return $ M "(packMapZeroTerminatedStorableArray (fromIntegral . fromEnum))"+    | TCArray True _ _ (TBasicType TGType) <- t =+        return $ M "(packMapZeroTerminatedStorableArray gtypeToCGtype)"+    | TCArray True _ _ (TBasicType _) <- t =+        return $ M "packZeroTerminatedStorableArray"+    | TCArray False _ _ (TBasicType TUTF8) <- t =+        return $ M "packUTF8CArray"+    | TCArray False _ _ (TBasicType TFileName) <- t =+        return $ M "packFileNameArray"+    | TCArray False _ _ (TBasicType TVoid) <- t =+        return $ M "packPtrArray"+    | TCArray False _ _ (TBasicType TUInt8) <- t =+        return $ M "packByteString"+    | TCArray False _ _ (TBasicType TBoolean) <- t =+        return $ M "(packMapStorableArray (fromIntegral . fromEnum))"+    | TCArray False _ _ (TBasicType TGType) <- t =+        return $ M "(packMapStorableArray gtypeToCGType)"+    | TCArray False _ _ (TBasicType TFloat) <- t =+        return $ M "(packMapStorableArray realToFrac)"+    | TCArray False _ _ (TBasicType TDouble) <- t =+        return $ M "(packMapStorableArray realToFrac)"+    | TCArray False _ _ (TBasicType _) <- t =+        return $ M "packStorableArray"+    | TCArray{}  <- t = notImplementedError $+                   "Don't know how to pack C array of type " ++ show t+    | otherwise = case (show hType, show fType) of+               ("T.Text", "CString") -> return $ M "textToCString"+               ("[Char]", "CString") -> return $ M "stringToCString"+               ("Char", "CInt")      -> return "(fromIntegral . ord)"+               ("Bool", "CInt")      -> return "(fromIntegral . fromEnum)"+               ("Float", "CFloat")   -> return "realToFrac"+               ("Double", "CDouble") -> return "realToFrac"+               ("GType", "CGType")   -> return "gtypeToCGType"+               _                     -> notImplementedError $+                                        "Don't know how to convert "+                                        ++ show hType ++ " into "+                                        ++ show fType ++ ".\n"+                                        ++ "Internal type: "+                                        ++ show t++getForeignConstructor :: Type -> Transfer -> ExcCodeGen Constructor+getForeignConstructor t transfer = do+  a <- findAPI t+  hType <- haskellType t+  fType <- foreignType t+  hToF' t a hType fType transfer++hToF_PackedType :: Type -> String -> Transfer -> ExcCodeGen Converter+hToF_PackedType t packer transfer = do+  innerConstructor <- getForeignConstructor t transfer+  return $ do+    mapC innerConstructor+    apply (M packer)++-- | Try to find the `hash` and `equal` functions appropriate for the+-- given type, when used as a key in a GHashTable.+hashTableKeyMappings :: Type -> ExcCodeGen (String, String)+hashTableKeyMappings (TBasicType TVoid) = return ("gDirectHash", "gDirectEqual")+hashTableKeyMappings (TBasicType TUTF8) = return ("gStrHash", "gStrEqual")+hashTableKeyMappings t =+    notImplementedError $ "GHashTable key of type " ++ show t ++ " unsupported."++-- | `GHashTable` tries to fit every type into a pointer, the+-- following function tries to find the appropriate+-- (destroy,packer,unpacker) for the given type.+hashTablePtrPackers :: Type -> ExcCodeGen (String, String, String)+hashTablePtrPackers (TBasicType TVoid) =+    return ("Nothing", "ptrPackPtr", "ptrUnpackPtr")+hashTablePtrPackers (TBasicType TUTF8) =+    return ("(Just ptr_to_g_free)", "cstringPackPtr", "cstringUnpackPtr")+hashTablePtrPackers t =+    notImplementedError $ "GHashTable element of type " ++ show t ++ " unsupported."++hToF_PackGHashTable :: Type -> Type -> ExcCodeGen Converter+hToF_PackGHashTable keys elems = do+  -- We will be adding elements to the Hash list with appropriate+  -- destructors, so we always want a fresh copy.+  keysConstructor <- getForeignConstructor keys TransferEverything+  elemsConstructor <- getForeignConstructor elems TransferEverything+  (keyHash, keyEqual) <- hashTableKeyMappings keys+  (keyDestroy, keyPack, _) <- hashTablePtrPackers keys+  (elemDestroy, elemPack, _) <- hashTablePtrPackers elems+  return $ do+    apply (P "Map.toList")+    mapFirst keysConstructor+    mapSecond elemsConstructor+    mapFirst (P keyPack)+    mapSecond (P elemPack)+    apply (M (intercalate " " ["packGHashTable", keyHash, keyEqual,+                               keyDestroy, elemDestroy]))++hToF :: Type -> Transfer -> ExcCodeGen Converter+hToF (TGList t) transfer = hToF_PackedType t "packGList" transfer+hToF (TGSList t) transfer = hToF_PackedType t "packGSList" transfer+hToF (TGArray t) transfer = hToF_PackedType t "packGArray" transfer+hToF (TPtrArray t) transfer = hToF_PackedType t "packGPtrArray" transfer+hToF (TGHash ta tb) _ = hToF_PackGHashTable ta tb+-- Arrays without length info are just passed along.+hToF (TCArray False (-1) (-1) _) _ = return $ Pure ()+hToF (TCArray zt _ _ t@(TCArray{})) transfer = do+  let packer = if zt+               then "packZeroTerminated"+               else "pack"+  hToF_PackedType t (packer ++ "PtrArray") transfer++hToF (TCArray zt _ _ t@(TInterface _ _)) transfer = do+  isScalar <- getIsScalar t+  let packer = if zt+               then "packZeroTerminated"+               else "pack"+  if isScalar+  then hToF_PackedType t (packer ++ "StorableArray") transfer+  else do+    api <- findAPI t+    let size = case api of+                 Just (APIStruct s) -> structSize s+                 Just (APIUnion u) -> unionSize u+                 _ -> 0+    if size == 0 || zt+    then hToF_PackedType t (packer ++ "PtrArray") transfer+    else hToF_PackedType t (packer ++ "BlockArray " ++ show size) transfer++hToF t transfer = do+  a <- findAPI t+  hType <- haskellType t+  fType <- foreignType t+  constructor <- hToF' t a hType fType transfer+  return $ apply constructor++boxedForeignPtr :: String -> Transfer -> CodeGen Constructor+boxedForeignPtr constructor transfer = return $+   case transfer of+     TransferEverything -> M $ parenthesize $ "wrapBoxed " ++ constructor+     _ -> M $ parenthesize $ "newBoxed " ++ constructor++suForeignPtr :: Bool -> Int -> TypeRep -> Transfer -> CodeGen Constructor+suForeignPtr isBoxed size hType transfer = do+  let constructor = tyConName $ typeRepTyCon hType+  if isBoxed then+      boxedForeignPtr constructor transfer+  else case size of+         0 -> do+           line "-- XXX Wrapping a foreign struct/union with no known destructor, leak?"+           return $ M $ parenthesize $+                      "\\x -> " ++ constructor ++ " <$> newForeignPtr_ x"+         n -> return $ M $ parenthesize $+              case transfer of+                TransferEverything -> "wrapPtr " ++ constructor+                _ -> "newPtr " ++ show n ++ " " ++ constructor++structForeignPtr :: Struct -> TypeRep -> Transfer -> CodeGen Constructor+structForeignPtr s =+    suForeignPtr (structIsBoxed s) (structSize s)++unionForeignPtr :: Union -> TypeRep -> Transfer -> CodeGen Constructor+unionForeignPtr u =+    suForeignPtr (unionIsBoxed u) (unionSize u)++fObjectToH :: Type -> TypeRep -> Transfer -> ExcCodeGen Constructor+fObjectToH t hType transfer = do+  let constructor = tyConName $ typeRepTyCon hType+  isGO <- isGObject t+  case transfer of+    TransferEverything ->+        if isGO+        then return $ M $ parenthesize $ "wrapObject " ++ constructor+        else badIntroError "Got a transfer of something not a GObject"+    _ ->+        if isGO+        then return $ M $ parenthesize $ "newObject " ++ constructor+        else badIntroError "Wrapping not a GObject with no copy..."++fCallbackToH :: Callback -> TypeRep -> Transfer -> ExcCodeGen Constructor+fCallbackToH _ _ _ =+  notImplementedError "Wrapping foreign callbacks is not supported yet"++fVariantToH :: Transfer -> CodeGen Constructor+fVariantToH transfer =+  return $ M $ case transfer of+                  TransferEverything -> "wrapGVariantPtr"+                  _ -> "newGVariantFromPtr"++fParamSpecToH :: Transfer -> CodeGen Constructor+fParamSpecToH transfer =+  return $ M $ case transfer of+                  TransferEverything -> "wrapGParamSpecPtr"+                  _ -> "newGParamSpecFromPtr"++fToH' :: Type -> Maybe API -> TypeRep -> TypeRep -> Transfer+         -> ExcCodeGen Constructor+fToH' t a hType fType transfer+    | ( hType == fType ) = return Id+    | Just (APIEnum _) <- a = return "(toEnum . fromIntegral)"+    | Just (APIFlags _) <- a = return "wordToGFlags"+    | TError <- t = boxedForeignPtr "GError" transfer+    | TVariant <- t = fVariantToH transfer+    | TParamSpec <- t = fParamSpecToH transfer+    | Just (APIStruct s) <- a = structForeignPtr s hType transfer+    | Just (APIUnion u) <- a = unionForeignPtr u hType transfer+    | Just (APIObject _) <- a = fObjectToH t hType transfer+    | Just (APIInterface _) <- a = fObjectToH t hType transfer+    | Just (APICallback c) <- a = fCallbackToH c hType transfer+    | TCArray True _ _ (TBasicType TUTF8) <- t =+        return $ M "unpackZeroTerminatedUTF8CArray"+    | TCArray True _ _ (TBasicType TFileName) <- t =+        return $ M "unpackZeroTerminatedFileNameArray"+    | TCArray True _ _ (TBasicType TUInt8) <- t =+        return $ M "unpackZeroTerminatedByteString"+    | TCArray True _ _ (TBasicType TVoid) <- t =+        return $ M "unpackZeroTerminatedPtrArray"+    | TCArray True _ _ (TBasicType TBoolean) <- t =+        return $ M "(unpackMapZeroTerminatedStorableArray (/= 0))"+    | TCArray True _ _ (TBasicType TGType) <- t =+        return $ M "(unpackMapZeroTerminatedStorableArray GType)"+    | TCArray True _ _ (TBasicType TFloat) <- t =+        return $ M "(unpackMapZeroTerminatedStorableArray realToFrac)"+    | TCArray True _ _ (TBasicType TDouble) <- t =+        return $ M "(unpackMapZeroTerminatedStorableArray realToFrac)"+    | TCArray True _ _ (TBasicType _) <- t =+        return $ M "unpackZeroTerminatedStorableArray"+    | TCArray{}  <- t = notImplementedError $+                   "Don't know how to unpack C array of type " ++ show t+    | TByteArray <- t = return $ M "unpackGByteArray"+    | TGHash _ _ <- t = notImplementedError "Foreign Hashes not supported yet"+    | otherwise = case (show fType, show hType) of+               ("CString", "T.Text") -> return $ M "cstringToText"+               ("CString", "[Char]") -> return $ M "cstringToString"+               ("CInt", "Char")      -> return "(chr . fromIntegral)"+               ("CInt", "Bool")      -> return "(/= 0)"+               ("CFloat", "Float")   -> return "realToFrac"+               ("CDouble", "Double") -> return "realToFrac"+               ("CGType", "GType")   -> return "GType"+               _                     ->+                   notImplementedError $ "Don't know how to convert "+                                           ++ show fType ++ " into "+                                           ++ show hType ++ ".\n"+                                           ++ "Internal type: "+                                           ++ show t++getHaskellConstructor :: Type -> Transfer -> ExcCodeGen Constructor+getHaskellConstructor t transfer = do+  a <- findAPI t+  hType <- haskellType t+  fType <- foreignType t+  fToH' t a hType fType transfer++fToH_PackedType :: Type -> String -> Transfer -> ExcCodeGen Converter+fToH_PackedType t unpacker transfer = do+  innerConstructor <- getHaskellConstructor t transfer+  return $ do+    apply (M unpacker)+    mapC innerConstructor++fToH_UnpackGHashTable :: Type -> Type -> Transfer -> ExcCodeGen Converter+fToH_UnpackGHashTable keys elems transfer = do+  keysConstructor <- getHaskellConstructor keys transfer+  (_,_,keysUnpack) <- hashTablePtrPackers keys+  elemsConstructor <- getHaskellConstructor elems transfer+  (_,_,elemsUnpack) <- hashTablePtrPackers elems+  return $ do+    apply (M "unpackGHashTable")+    mapFirst (P keysUnpack)+    mapFirst keysConstructor+    mapSecond (P elemsUnpack)+    mapSecond elemsConstructor+    apply (P "Map.fromList")++fToH :: Type -> Transfer -> ExcCodeGen Converter++fToH (TGList t) transfer = fToH_PackedType t "unpackGList" transfer+fToH (TGSList t) transfer = fToH_PackedType t "unpackGSList" transfer+fToH (TGArray t) transfer = fToH_PackedType t "unpackGArray" transfer+fToH (TPtrArray t) transfer = fToH_PackedType t "unpackGPtrArray" transfer+fToH (TGHash a b) transfer = fToH_UnpackGHashTable a b transfer+-- Arrays without length info are just passed along.+fToH (TCArray False (-1) (-1) _) _ = return $ Pure ()+fToH (TCArray True _ _ t@(TCArray{})) transfer =+  fToH_PackedType t "unpackZeroTerminatedPtrArray" transfer+fToH (TCArray True _ _ t@(TInterface _ _)) transfer = do+  isScalar <- getIsScalar t+  if isScalar+  then fToH_PackedType t "unpackZeroTerminatedStorableArray" transfer+  else fToH_PackedType t "unpackZeroTerminatedPtrArray" transfer++fToH t transfer = do+  a <- findAPI t+  hType <- haskellType t+  fType <- foreignType t+  constructor <- fToH' t a hType fType transfer+  return $ apply constructor++unpackCArray :: String -> Type -> Transfer -> ExcCodeGen Converter+unpackCArray length (TCArray False _ _ t) transfer =+  case t of+    TBasicType TUTF8 -> return $ apply $ M $ parenthesize $+                        "unpackUTF8CArrayWithLength " ++ length+    TBasicType TFileName -> return $ apply $ M $ parenthesize $+                            "unpackFileNameArrayWithLength " ++ length+    TBasicType TUInt8 -> return $ apply $ M $ parenthesize $+                         "unpackByteStringWithLength " ++ length+    TBasicType TVoid -> return $ apply $ M $ parenthesize $+                         "unpackPtrArrayWithLength " ++ length+    TBasicType TBoolean -> return $ apply $ M $ parenthesize $+                         "unpackMapStorableArrayWithLength (/= 0) " ++ length+    TBasicType TGType -> return $ apply $ M $ parenthesize $+                         "unpackMapStorableArrayWithLength GType " ++ length+    TBasicType TFloat -> return $ apply $ M $ parenthesize $+                         "unpackMapStorableArrayWithLength realToFrac " ++ length+    TBasicType TDouble -> return $ apply $ M $ parenthesize $+                         "unpackMapStorableArrayWithLength realToFrac " ++ length+    TBasicType _ -> return $ apply $ M $ parenthesize $+                         "unpackStorableArrayWithLength " ++ length+    TInterface _ _ -> do+           a <- findAPI t+           isScalar <- getIsScalar t+           hType <- haskellType t+           fType <- foreignType t+           innerConstructor <- fToH' t a hType fType transfer+           let (boxed, size) = case a of+                        Just (APIStruct s) -> (structIsBoxed s, structSize s)+                        Just (APIUnion u) -> (unionIsBoxed u, unionSize u)+                        _ -> (False, 0)+           let unpacker | isScalar    = "unpackStorableArrayWithLength"+                        | (size == 0) = "unpackPtrArrayWithLength"+                        | boxed       = "unpackBoxedArrayWithLength " ++ show size+                        | otherwise   = "unpackBlockArrayWithLength " ++ show size+           return $ do+             apply $ M $ parenthesize $ unpacker ++ " " ++ length+             mapC innerConstructor+    _ -> notImplementedError $+         "unpackCArray : Don't know how to unpack C Array of type " ++ show t++unpackCArray _ _ _ = notImplementedError "unpackCArray : unexpected array type."++-- Given a type find the typeclasses the type belongs to, and return+-- the representation of the type in the function signature and the+-- list of typeclass constraints for the type.+argumentType :: [Char] -> Type -> CodeGen ([Char], String, [String])+argumentType [] _               = error "out of letters"+argumentType letters (TGList a) = do+  (ls, name, constraints) <- argumentType letters a+  return (ls, "[" ++ name ++ "]", constraints)+argumentType letters (TGSList a) = do+  (ls, name, constraints) <- argumentType letters a+  return (ls, "[" ++ name ++ "]", constraints)+argumentType letters@(l:ls) t   = do+  api <- findAPI t+  s <- show <$> haskellType t+  case api of+    Just (APIInterface _) -> do+             let constraints = [classConstraint s ++ " " ++ [l]]+             return (ls, [l], constraints)+    -- Instead of restricting to the actual class,+    -- we allow for any object descending from it.+    Just (APIObject _) -> do+        isGO <- isGObject t+        if isGO+        then return (ls, [l], [classConstraint s ++ " " ++ [l]])+        else return (letters, s, [])+    _ -> return (letters, s, [])++haskellBasicType TVoid     = ptr $ typeOf ()+haskellBasicType TBoolean  = typeOf True+haskellBasicType TInt8     = typeOf (0 :: Int8)+haskellBasicType TUInt8    = typeOf (0 :: Word8)+haskellBasicType TInt16    = typeOf (0 :: Int16)+haskellBasicType TUInt16   = typeOf (0 :: Word16)+haskellBasicType TInt32    = typeOf (0 :: Int32)+haskellBasicType TUInt32   = typeOf (0 :: Word32)+haskellBasicType TInt64    = typeOf (0 :: Int64)+haskellBasicType TUInt64   = typeOf (0 :: Word64)+haskellBasicType TGType    = "GType" `con` []+haskellBasicType TUTF8     = "T.Text" `con` []+haskellBasicType TFloat    = typeOf (0 :: Float)+haskellBasicType TDouble   = typeOf (0 :: Double)+haskellBasicType TUniChar  = typeOf ('\0' :: Char)+haskellBasicType TFileName = "[Char]" `con` []++-- This translates GI types to the types used for generated Haskell code.+haskellType :: Type -> CodeGen TypeRep+haskellType (TBasicType bt) = return $ haskellBasicType bt+-- We cannot really do anything sensible for a foreign array with no+-- length info, so just pass the pointer along.+haskellType (TCArray False (-1) (-1) t) =+    ptr <$> foreignType t+haskellType (TCArray _ _ _ (TBasicType TUInt8)) =+    return $ "ByteString" `con` []+haskellType (TCArray _ _ _ a) = do+  inner <- haskellType a+  return $ "[]" `con` [inner]+haskellType (TGArray a) = do+  inner <- haskellType a+  return $ "[]" `con` [inner]+haskellType (TPtrArray a) = do+  inner <- haskellType a+  return $ "[]" `con` [inner]+haskellType (TByteArray) = return $ "ByteString" `con` []+haskellType (TGList a) = do+  inner <- haskellType a+  return $ "[]" `con` [inner]+haskellType (TGSList a) = do+  inner <- haskellType a+  return $ "[]" `con` [inner]+haskellType (TGHash a b) = do+  innerA <- haskellType a+  innerB <- haskellType b+  return $ "Map.Map" `con` [innerA, innerB]+haskellType TError = return $ "GError" `con` []+haskellType TVariant = return $ "GVariant" `con` []+haskellType TParamSpec = return $ "GParamSpec" `con` []+haskellType (TInterface "GObject" "Value") = return $ "GValue" `con` []+haskellType (TInterface "GObject" "Closure") = return $ "Closure" `con` []+haskellType t@(TInterface ns n) = do+  prefix <- qualify ns+  api <- findAPI t+  let tname = T.pack (prefix ++ n) `con` []+  return $ case api of+             Just (APIFlags _) -> "[]" `con` [tname]+             _ -> tname++foreignBasicType TVoid     = ptr (typeOf ())+foreignBasicType TBoolean  = "CInt" `con` []+foreignBasicType TUTF8     = "CString" `con` []+foreignBasicType TFileName = "CString" `con` []+foreignBasicType TUniChar  = "CInt" `con` []+foreignBasicType TFloat    = "CFloat" `con` []+foreignBasicType TDouble   = "CDouble" `con` []+foreignBasicType TGType    = "CGType" `con` []+foreignBasicType t         = haskellBasicType t++-- This translates GI types to the types used in foreign function calls.+foreignType :: Type -> CodeGen TypeRep+foreignType (TBasicType t) = return $ foreignBasicType t+foreignType (TCArray False (-1) (-1) t) =+    ptr <$> foreignType t+foreignType (TCArray zt _ _ t) = do+  api <- findAPI t+  let size = case api of+               Just (APIStruct s) -> structSize s+               Just (APIUnion u) -> unionSize u+               _ -> 0+  if size == 0 || zt+  then ptr <$> foreignType t+  else foreignType t+foreignType (TGArray a) = do+  inner <- foreignType a+  return $ ptr ("GArray" `con` [inner])+foreignType (TPtrArray a) = do+  inner <- foreignType a+  return $ ptr ("GPtrArray" `con` [inner])+foreignType (TByteArray) = return $ ptr ("GByteArray" `con` [])+foreignType (TGList a) = do+  inner <- foreignType a+  return $ ptr ("GList" `con` [inner])+foreignType (TGSList a) = do+  inner <- foreignType a+  return $ ptr ("GSList" `con` [inner])+foreignType (TGHash a b) = do+  innerA <- foreignType a+  innerB <- foreignType b+  return $ ptr ("GHashTable" `con` [innerA, innerB])+foreignType t@TError = ptr <$> haskellType t+foreignType t@TVariant = ptr <$> haskellType t+foreignType t@TParamSpec = ptr <$> haskellType t+foreignType (TInterface "GObject" "Value") = return $ ptr $ "GValue" `con` []+foreignType (TInterface "GObject" "Closure") =+    return $ ptr $ "Closure" `con` []+foreignType t@(TInterface ns n) = do+  isScalar <- getIsScalar t+  if isScalar+  then return $ "CUInt" `con` []+  else do+    api <- findAPI t+    prefix <- qualify ns+    return $ case api of+               Just (APICallback _) -> T.pack ("FunPtr " ++ prefix ++ n ++ "C")+                                       `con` []+               _ -> ptr $ T.pack (prefix ++ n) `con` []++getIsScalar :: Type -> CodeGen Bool+getIsScalar t = do+  a <- findAPI t+  case a of+    Nothing -> return False+    (Just (APIEnum _)) -> return True+    (Just (APIFlags _)) -> return True+    _ -> return False++-- Whether the given type corresponds to a struct we allocate+-- ourselves. If we need to allocate the struct we return its size in+-- bytes and whether the type is boxed, otherwise we return Nothing.+requiresAlloc :: Type -> CodeGen (Maybe (Bool, Int))+requiresAlloc t = do+  api <- findAPI t+  case api of+    Just (APIStruct s) -> case structSize s of+                            0 -> return Nothing+                            n -> return (Just (structIsBoxed s, n))+    _ -> return Nothing++-- Returns whether the given type corresponds to a ManagedPtr+-- instance (a thin wrapper over a ForeignPtr).+isManaged   :: Type -> CodeGen Bool+isManaged t = do+  a <- findAPI t+  case a of+    Just (APIObject _)    -> return True+    Just (APIInterface _) -> return True+    Just (APIStruct _)    -> return True+    Just (APIUnion _)     -> return True+    _                     -> return False++-- Returns whether the given type is nullable in the C sense,+-- i.e. whether it can be set to NULL.+isNullable :: Type -> Bool+isNullable (TBasicType TVoid) = True+isNullable (TBasicType TUTF8) = True+isNullable (TBasicType TFileName) = True+isNullable (TBasicType _) = False+isNullable _ = True++-- If the given type maps to a list in Haskell, return the type of the+-- elements, and the function that maps over them.+elementTypeAndMap :: Type -> String -> Maybe (Type, String)+-- Passed along as a raw pointer.+elementTypeAndMap (TCArray False (-1) (-1) _) _ = Nothing+-- ByteString+elementTypeAndMap (TCArray _ _ _ (TBasicType TUInt8)) _ = Nothing+elementTypeAndMap (TCArray True _ _ t) _ = Just (t, "mapZeroTerminatedCArray")+elementTypeAndMap (TCArray False (-1) _ t) len =+    Just (t, parenthesize $ "mapCArrayWithLength " ++ len)+elementTypeAndMap (TCArray False fixed _ t) _ =+    Just (t, parenthesize $ "mapCArrayWithLength " ++ show fixed)+elementTypeAndMap (TGArray t) _ = Just (t, "mapGArray")+elementTypeAndMap (TPtrArray t) _ = Just (t, "mapPtrArray")+elementTypeAndMap (TGList t) _ = Just (t, "mapGList")+elementTypeAndMap (TGSList t) _ = Just (t, "mapGSList")+-- GHashTable is treated separately, see Transfer.hs+elementTypeAndMap _ _ = Nothing++-- Return just the element type.+elementType :: Type -> Maybe Type+elementType t = fst <$> elementTypeAndMap t undefined++-- Return just the map.+elementMap :: Type -> String -> Maybe String+elementMap t len = snd <$> elementTypeAndMap t len
+ src/GI/GIR/Alias.hs view
@@ -0,0 +1,40 @@+module GI.GIR.Alias+    ( documentListAliases+    ) where++import qualified Data.Map as M+import Data.Text (Text)+import qualified Data.Text as T+import Text.XML (Element(elementAttributes), Document(documentRoot))++import GI.Type (Type)+import GI.GIR.BasicTypes (Alias(..))+import GI.GIR.Type (parseType)+import GI.GIR.Parser+import GI.GIR.XMLUtils (childElemsWithLocalName)++-- | Find all aliases in a given namespace.+namespaceListAliases :: Element -> M.Map Alias Type+namespaceListAliases ns =+    case M.lookup "name" (elementAttributes ns) of+      Nothing -> error $ "Namespace with no name!"+      Just nsName -> case runParser nsName M.empty ns parseAliases of+                       Left err -> (error . T.unpack) err+                       Right aliases -> M.fromList (map addNS aliases)+                           where addNS (n, t) = (Alias (nsName, n), t)++-- | Parse all the aliases in the current namespace+parseAliases :: Parser [(Text, Type)]+parseAliases = parseChildrenWithLocalName "alias" parseAlias++-- | Parse a single alias+parseAlias :: Parser (Text, Type)+parseAlias = do+  name <- getAttr "name"+  t <- parseType+  return (name, t)++-- | Find all aliases in a given document.+documentListAliases :: Document -> M.Map Alias Type+documentListAliases doc = M.unions (map namespaceListAliases namespaces)+    where namespaces = childElemsWithLocalName "namespace" (documentRoot doc)
+ src/GI/GIR/BasicTypes.hs view
@@ -0,0 +1,21 @@+-- | Basic types used in GIR parsing.+module GI.GIR.BasicTypes+    ( Name(..)+    , Transfer(..)+    , Alias(..)+    ) where++import Data.Text (Text)++-- | Name for a symbol in the GIR file.+data Name = Name { namespace :: String, name :: String }+    deriving (Eq, Ord, Show)++-- | Transfer mode for an argument or property.+data Transfer = TransferNothing+              | TransferContainer+              | TransferEverything+                deriving (Show, Eq, Ord)++-- | An alias, which is simply (Namespace, name).+newtype Alias = Alias (Text, Text) deriving (Ord, Eq, Show)
+ src/GI/GIR/Callback.hs view
@@ -0,0 +1,17 @@+-- | Parsing of callbacks.+module GI.GIR.Callback+    ( Callback(..)+    , parseCallback+    ) where++import GI.GIR.Parser+import GI.GIR.Callable (Callable, parseCallable)++data Callback = Callback Callable+    deriving Show++parseCallback :: Parser (Name, Callback)+parseCallback = do+  name <- parseName+  callable <- parseCallable+  return (name, Callback callable)
+ src/GI/GIR/Constant.hs view
@@ -0,0 +1,27 @@+-- | Parsing of constants in GIR files.+module GI.GIR.Constant+    ( Constant(..)+    , parseConstant+    ) where++import Data.Text (Text)++import GI.Type (Type)+import GI.GIR.Type (parseType)+import GI.GIR.Parser++-- | Info about a constant.+data Constant = Constant {+      constantType        :: Type,+      constantValue       :: Text,+      constantDeprecated  :: Maybe DeprecationInfo+    } deriving (Show)++-- | Parse a "constant" element from the GIR file.+parseConstant :: Parser (Name, Constant)+parseConstant = do+  name <- parseName+  deprecated <- parseDeprecation+  value <- getAttr "value"+  t <- parseType+  return (name, Constant t value deprecated)
+ src/GI/GIR/Deprecation.hs view
@@ -0,0 +1,42 @@+module GI.GIR.Deprecation+    ( DeprecationInfo+    , deprecatedPragma+    , queryDeprecated+    ) where++import qualified Data.Map as M+import qualified Data.Text as T+import Data.Text (Text)+import Text.XML (Element(elementAttributes))++import GI.GIR.XMLUtils (firstChildWithLocalName, getElementContent)++-- | Deprecation information on a symbol.+data DeprecationInfo = DeprecationInfo {+      deprecatedSinceVersion :: Maybe Text,+      deprecationMessage     :: Maybe Text+    } deriving (Show, Eq)++-- | Encode the given `DeprecationInfo` for the given symbol as a+-- deprecation pragma.+deprecatedPragma :: String -> Maybe DeprecationInfo -> String+deprecatedPragma _    Nothing     = ""+deprecatedPragma name (Just info) = "{-# DEPRECATED " ++ name ++ " " +++                                    show (note ++ reason) ++ "#-}"+        where reason = case deprecationMessage info of+                         Nothing -> []+                         Just msg -> (lines . T.unpack) msg+              note = case deprecatedSinceVersion info of+                       Nothing -> []+                       Just v -> ["(Since version " ++ T.unpack v ++ ")"]++-- | Parse the deprecation information for the given element of the GIR file.+queryDeprecated :: Element -> Maybe DeprecationInfo+queryDeprecated element =+    case M.lookup "deprecated" attrs of+      Just _ -> let version = M.lookup "deprecated-version" attrs+                    msg = firstChildWithLocalName "doc-deprecated" element >>=+                          getElementContent+                in Just (DeprecationInfo version msg)+      Nothing -> Nothing+    where attrs = elementAttributes element
+ src/GI/GIR/Enum.hs view
@@ -0,0 +1,52 @@+-- | Parsing of Enums.+module GI.GIR.Enum+    ( Enumeration(..)+    , parseEnum+    ) where++import Data.Int (Int64)+import Data.Text (Text)+import Foreign.C (CInt(..))++import GI.GIR.Parser++data Enumeration = Enumeration {+    enumValues :: [(Text, Int64)],+    errorDomain :: Maybe Text,+    enumTypeInit :: Maybe Text,+    enumStorageBytes :: Int, -- ^ Bytes used for storage of this struct.+    enumDeprecated :: Maybe DeprecationInfo }+    deriving Show++-- | Parse a struct member.+parseEnumMember :: Parser (Text, Int64)+parseEnumMember = do+  name <- getAttr "name"+  value <- getAttr "value" >>= parseIntegral+  return (name, value)++foreign import ccall "_gi_get_enum_storage_bytes" get_storage_bytes ::+    Int64 -> Int64 -> CInt++-- | Return the number of bytes that should be allocated for storage+-- of the given values in an enum.+extractEnumStorageBytes :: [Int64] -> Int+extractEnumStorageBytes values =+    fromIntegral $ get_storage_bytes (minimum values) (maximum values)++-- | Parse an "enumeration" element from the GIR file.+parseEnum :: Parser (Name, Enumeration)+parseEnum = do+  name <- parseName+  deprecated <- parseDeprecation+  errorDomain <- queryAttrWithNamespace GLibGIRNS "error-domain"+  typeInit <- queryAttrWithNamespace GLibGIRNS "get-type"+  values <- parseChildrenWithLocalName "member" parseEnumMember+  return (name,+          Enumeration {+            enumValues = values+          , errorDomain = errorDomain+          , enumTypeInit = typeInit+          , enumStorageBytes = extractEnumStorageBytes (map snd values)+          , enumDeprecated = deprecated+          })
+ src/GI/GIR/Field.hs view
@@ -0,0 +1,75 @@+-- | Parsing of object/struct/union fields.+module GI.GIR.Field+    ( Field(..)+    , FieldInfoFlag+    , parseFields+    ) where++import Data.Monoid ((<>))+import Data.Text (Text)++import GI.Type (Type(..))++import GI.GIR.Callback (Callback, parseCallback)+import GI.GIR.Type (parseType)+import GI.GIR.Parser++data Field = Field {+      fieldName :: Text,+      fieldVisible :: Bool,+      fieldType :: Type,+      fieldCallback :: Maybe Callback,+      fieldOffset :: Int,+      fieldFlags :: [FieldInfoFlag],+      fieldDeprecated :: Maybe DeprecationInfo }+    deriving Show++data FieldInfoFlag = FieldIsReadable | FieldIsWritable+                   deriving Show++-- | Parse a single field in a struct or union. We parse+-- non-introspectable fields too (but set fieldVisible = False for+-- them), this is necessary since they affect the computation of+-- offsets of fields and sizes of containing structs.+parseField :: Parser Field+parseField = do+  name <- getAttr "name"+  deprecated <- parseDeprecation+  readable <- optionalAttr "readable" True parseBool+  writable <- optionalAttr "writable" False parseBool+  let flags = if readable then [FieldIsReadable] else []+             <> if writable then [FieldIsWritable] else []+  introspectable <- optionalAttr "introspectable" True parseBool+  private <- optionalAttr "private" False parseBool+  (t, callback) <-+      if introspectable+      then do+        callbacks <- parseChildrenWithLocalName "callback" parseCallback+        (cbn, callback) <- case callbacks of+                             [] -> return (Nothing, Nothing)+                             [(n, cb)] -> return (Just n, Just cb)+                             _ -> parseError "Multiple callbacks in field"+        t <- case cbn of+               Nothing -> parseType+               Just (Name ns n) -> return (TInterface ns n)+        return (t, callback)+      else do+        callbacks <- parseAllChildrenWithLocalName "callback" parseName+        case callbacks of+          [] -> do+               t <- parseType+               return (t, Nothing)+          [Name ns n] -> return (TInterface ns n, Nothing)+          _ -> parseError "Multiple callbacks in field"+  return $ Field {+               fieldName = name+             , fieldVisible = introspectable && not private+             , fieldType = t+             , fieldCallback = callback+             , fieldOffset = error ("unfixed field offset " ++ show name)+             , fieldFlags = flags+             , fieldDeprecated = deprecated+          }++parseFields :: Parser [Field]+parseFields = parseAllChildrenWithLocalName "field" parseField
+ src/GI/GIR/Flags.hs view
@@ -0,0 +1,17 @@+-- | Parsing of bitfields, a.k.a. flags. They are represented in the+-- same way as enums, so this is a thin wrapper over that code.+module GI.GIR.Flags+    ( Flags(..)+    , parseFlags+    ) where++import GI.GIR.Enum (Enumeration, parseEnum)+import GI.GIR.Parser++data Flags = Flags Enumeration+    deriving Show++parseFlags :: Parser (Name, Flags)+parseFlags = do+  (n, enum) <- parseEnum+  return (n, Flags enum)
+ src/GI/GIR/Method.hs view
@@ -0,0 +1,42 @@+module GI.GIR.Method+    ( Method(..)+    , MethodType(..)+    , parseMethod+    ) where++import Data.Text (Text)+import qualified Data.Text as T++import GI.GIR.Callable (Callable(..), parseCallable)+import GI.GIR.Parser++data MethodType = Constructor    -- ^ Constructs an instance of the parent type+                | MemberFunction -- ^ A function in the namespace+                | OrdinaryMethod -- ^ A function taking the parent+                                 -- instance as first argument.+                  deriving (Eq, Show)++data Method = Method {+      methodSymbol      :: Text,+      methodThrows      :: Bool,+      methodType        :: MethodType,+      methodCallable    :: Callable+    } deriving Show++parseMethod :: MethodType -> Parser (Name, Method)+parseMethod mType = do+  name <- parseName+  shadows <- queryAttr "shadows"+  let exposedName = case shadows of+                      Just n -> name {name = T.unpack n}+                      Nothing -> name+  callable <- parseCallable+  symbol <- getAttrWithNamespace CGIRNS "identifier"+  throws <- optionalAttr "throws" False parseBool+  return $ (exposedName,+            Method {+              methodSymbol = symbol+            , methodThrows = throws+            , methodType = mType+            , methodCallable = callable+            })
+ src/GI/GIR/Object.hs view
@@ -0,0 +1,49 @@+-- | Parsing of objects.+module GI.GIR.Object+    ( Object(..)+    , parseObject+    ) where++import Data.Text (Text)++import GI.GIR.Method (Method, parseMethod, MethodType(..))+import GI.GIR.Property (Property, parseProperty)+import GI.GIR.Signal (Signal, parseSignal)+import GI.GIR.Parser++data Object = Object {+    objParent :: Maybe Name,+    objTypeInit :: Text,+    objTypeName :: Text,+    objInterfaces :: [Name],+    objDeprecated :: Maybe DeprecationInfo,+    objMethods :: [(Name, Method)],+    objProperties :: [Property],+    objSignals :: [Signal]+    } deriving Show++parseObject :: Parser (Name, Object)+parseObject = do+  name <- parseName+  deprecated <- parseDeprecation+  methods <- parseChildrenWithLocalName "method" (parseMethod OrdinaryMethod)+  constructors <- parseChildrenWithLocalName "constructor" (parseMethod Constructor)+  functions <- parseChildrenWithLocalName "function" (parseMethod MemberFunction)+  parent <- optionalAttr "parent" Nothing (fmap Just . qualifyName)+  interfaces <- parseChildrenWithLocalName "implements" parseName+  props <- parseChildrenWithLocalName "property" parseProperty+  typeInit <- getAttrWithNamespace GLibGIRNS "get-type"+  typeName <- getAttrWithNamespace GLibGIRNS "type-name"+  signals <- parseChildrenWithNSName GLibGIRNS "signal" parseSignal+  return (name,+         Object {+            objParent = parent+          , objTypeInit = typeInit+          , objTypeName = typeName+          , objInterfaces = interfaces+          , objDeprecated = deprecated+          , objMethods = constructors ++ methods ++ functions+          , objProperties = props+          , objSignals = signals+          })+
+ src/GI/GIR/Parser.hs view
@@ -0,0 +1,230 @@+-- | The Parser monad.+module GI.GIR.Parser+    ( Parser+    , ParseError+    , parseError++    , runParser++    , parseName+    , parseDeprecation+    , parseIntegral+    , parseBool+    , parseChildrenWithLocalName+    , parseAllChildrenWithLocalName+    , parseChildrenWithNSName++    , getAttr+    , getAttrWithNamespace+    , queryAttr+    , queryAttrWithNamespace+    , optionalAttr++    , currentNamespace+    , qualifyName+    , resolveQualifiedTypeName++    -- Reexported for convenience+    , Name(..)+    , Element+    , GIRXMLNamespace(..)+    , DeprecationInfo+    ) where++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative ((<$>))+#endif++import Control.Monad.Except+import Control.Monad.Reader++import Data.Monoid ((<>))+import qualified Data.Map as M+import qualified Data.Text as T+import qualified Data.Text.Read as TR+import Data.Text (Text)+import qualified Text.XML as XML+import Text.XML (Element(elementAttributes))+import Text.Show.Pretty (ppShow)++import GI.Type (Type(TInterface))++import GI.GIR.BasicTypes (Name(..), Alias(..))+import GI.GIR.Deprecation (DeprecationInfo, queryDeprecated)+import GI.GIR.XMLUtils (localName, GIRXMLNamespace(..),+                        childElemsWithLocalName, childElemsWithNSName,+                        lookupAttr, lookupAttrWithNamespace)++-- | Info to carry around when parsing.+data ParseContext = ParseContext {+      ctxNamespace     :: Text,+      -- Location in the XML tree of the node being parsed (for+      -- debugging purposes).+      treePosition     :: [Text],+      -- Current element being parsed (to be set by withElement)+      currentElement   :: Element,+      knownAliases     :: M.Map Alias Type+    } deriving Show++-- | A message describing a parsing error in human readable form.+type ParseError = Text++-- | Monad where parsers live: we carry a context around, and can+-- throw errors that abort the parsing.+type Parser a = ReaderT ParseContext (Except ParseError) a++-- | Throw a parse error.+parseError :: ParseError -> Parser a+parseError msg = do+  ctx <- ask+  let position = (T.intercalate " / " . reverse . treePosition) ctx+  throwError $ "Error when parsing \"" <> position <> "\": " <> msg <> "\n"+                 <> (T.pack . ppShow . currentElement) ctx++-- | Build a textual description (for debug purposes) of a given element.+elementDescription :: Element -> Text+elementDescription element =+    case M.lookup "name" (elementAttributes element) of+      Nothing -> localName element+      Just n -> localName element <> " [" <> n <> "]"++-- | Build a name in the current namespace.+nameInCurrentNS :: Text -> Parser Name+nameInCurrentNS n = do+  ctx <- ask+  return $ Name (T.unpack (ctxNamespace ctx)) (T.unpack n)++-- | Return the current namespace.+currentNamespace :: Parser Text+currentNamespace = ctxNamespace <$> ask++-- | Check whether there is an alias for the given name, and return+-- the corresponding type in case it exists, and otherwise a TInterface.+resolveQualifiedTypeName :: Text -> Text -> Parser Type+resolveQualifiedTypeName ns n = do+  ctx <- ask+  case M.lookup (Alias (ns, n)) (knownAliases ctx) of+    -- The resolved type may be an alias itself, like for+    -- Gtk.Allocation -> Gdk.Rectangle -> cairo.RectangleInt+    Just (TInterface ns n) -> resolveQualifiedTypeName (T.pack ns) (T.pack n)+    Just t -> return t+    Nothing -> return $ TInterface (T.unpack ns) (T.unpack n)++-- | Return the value of an attribute for the given element. If the+-- attribute is not present this throws an error.+getAttr :: XML.Name -> Parser Text+getAttr attr = do+  ctx <- ask+  case lookupAttr attr (currentElement ctx) of+    Just val -> return val+    Nothing -> parseError $ "Expected attribute \"" <>+               (T.pack . show) attr <> "\" not present."++-- | Like 'getAttr', but allow for specifying the namespace.+getAttrWithNamespace :: GIRXMLNamespace -> XML.Name -> Parser Text+getAttrWithNamespace ns attr = do+  ctx <- ask+  case lookupAttrWithNamespace ns attr (currentElement ctx) of+    Just val -> return val+    Nothing -> parseError $ "Expected attribute \"" <>+               (T.pack . show) attr <> "\" in namespace \"" <>+               (T.pack . show) ns <> "\" not present."++-- | Return the value of an attribute if it is present, and Nothing otherwise.+queryAttr :: XML.Name -> Parser (Maybe Text)+queryAttr attr = do+  ctx <- ask+  return $ lookupAttr attr (currentElement ctx)++-- | Like `queryAttr`, but allow for specifying the namespace.+queryAttrWithNamespace :: GIRXMLNamespace -> XML.Name -> Parser (Maybe Text)+queryAttrWithNamespace ns attr = do+  ctx <- ask+  return $ lookupAttrWithNamespace ns attr (currentElement ctx)++-- | Ask for an optional attribute, applying the given parser to+-- it. If the argument does not exist return the default value provided.+optionalAttr :: XML.Name -> a -> (Text -> Parser a) -> Parser a+optionalAttr attr def parser =+    queryAttr attr >>= \case+              Just a -> parser a+              Nothing -> return def++-- | Build a 'Name' out of the (possibly qualified) supplied name. If+-- the supplied name is unqualified we qualify with the current+-- namespace, and otherwise we simply parse it.+qualifyName :: Text -> Parser Name+qualifyName n = case T.split (== '.') n of+    [ns, name] -> return $ Name (T.unpack ns) (T.unpack name)+    [name] -> nameInCurrentNS name+    _ -> parseError "Could not understand name"++-- | Get the qualified name for the current element.+parseName :: Parser Name+parseName = getAttr "name" >>= qualifyName++-- | Parse the deprecation text, if present.+parseDeprecation :: Parser (Maybe DeprecationInfo)+parseDeprecation = do+  ctx <- ask+  return $ queryDeprecated (currentElement ctx)++-- | Parse a signed integral number.+parseIntegral :: Integral a => Text -> Parser a+parseIntegral str =+    case TR.signed TR.decimal str of+      Right (n, r) | T.null r -> return n+      _ -> parseError $ "Could not parse integral value: \"" <> str <> "\"."++-- | A boolean value given by a numerical constant.+parseBool :: Text -> Parser Bool+parseBool "0" = return False+parseBool "1" = return True+parseBool other = parseError $ "Unsupported boolean value: " <> T.pack (show other)++-- | Parse all the introspectable subelements with the given local name.+parseChildrenWithLocalName :: Text -> Parser a -> Parser [a]+parseChildrenWithLocalName n parser = do+  ctx <- ask+  let introspectableChildren = filter introspectable+                               (childElemsWithLocalName n (currentElement ctx))+  mapM (withElement parser) introspectableChildren+      where introspectable :: Element -> Bool+            introspectable e = lookupAttr "introspectable" e /= Just "0" &&+                               lookupAttr "shadowed-by" e == Nothing++-- | Parse all subelements with the given local name.+parseAllChildrenWithLocalName :: Text -> Parser a -> Parser [a]+parseAllChildrenWithLocalName n parser = do+  ctx <- ask+  mapM (withElement parser) (childElemsWithLocalName n (currentElement ctx))++-- | Parse all introspectable children with the given namespace and+-- local name.+parseChildrenWithNSName :: GIRXMLNamespace -> Text -> Parser a -> Parser [a]+parseChildrenWithNSName ns n parser = do+  ctx <- ask+  let introspectableChildren = filter introspectable+                               (childElemsWithNSName ns n (currentElement ctx))+  mapM (withElement parser) introspectableChildren+      where introspectable :: Element -> Bool+            introspectable e = lookupAttr "introspectable" e /= Just "0"++-- | Run the given parser for a given subelement in the XML tree.+withElement :: Parser a -> Element -> Parser a+withElement parser element = local modifyParsePosition parser+    where modifyParsePosition ctx =+              ctx { treePosition = elementDescription element : treePosition ctx+                  , currentElement = element}++-- | Run the given parser, returning either success or an error.+runParser :: Text -> M.Map Alias Type -> Element -> Parser a ->+             Either ParseError a+runParser ns aliases element parser =+    runExcept (runReaderT parser ctx)+              where ctx = ParseContext {+                            ctxNamespace = ns+                          , treePosition = [elementDescription element]+                          , currentElement = element+                          , knownAliases = aliases+                          }
+ src/GI/GIR/Repository.hs view
@@ -0,0 +1,62 @@+module GI.GIR.Repository (readGiRepository) where++import Prelude hiding (readFile)++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative ((<$>))+#endif++import Control.Monad (when)+import Data.Maybe+import qualified Data.List as List+import qualified Data.Text as T+import Data.Text (Text)+import Safe (maximumMay)+import Text.XML++import System.Directory+import System.Environment.XDG.BaseDir (getSystemDataDirs)+import System.FilePath++girDataDirs :: IO [FilePath]+girDataDirs = getSystemDataDirs "gir-1.0"++girFilePath :: String -> String -> FilePath -> FilePath+girFilePath name version path = path </> name ++ "-" ++ version <.> "gir"++girFile' :: Text -> Maybe Text -> FilePath -> IO (Maybe FilePath)+girFile' name (Just version) path =+    let filePath = girFilePath (T.unpack name) (T.unpack version) path+    in  doesFileExist filePath >>= \case+        True  -> return $ Just filePath+        False -> return Nothing+girFile' name Nothing path =+    doesDirectoryExist path >>= \case+        True -> do+            repositories <- map takeBaseName <$> getDirectoryContents path+            let version = maximumMay . catMaybes $+                    List.stripPrefix (T.unpack name ++ "-") <$> repositories++            return $ case version of+                Just v  -> Just $ girFilePath (T.unpack name) v path+                Nothing -> Nothing++        False -> return Nothing++girFile :: Text -> Maybe Text -> [FilePath] -> IO (Maybe FilePath)+girFile name version extraPaths = do+  dataDirs <- girDataDirs+  firstJust <$> (mapM (girFile' name version) (extraPaths ++ dataDirs))+    where firstJust = listToMaybe . catMaybes++readGiRepository :: Bool -> Text -> Maybe Text -> [FilePath] -> IO Document+readGiRepository verbose name version extraPaths =+    girFile name version extraPaths >>= \case+        Just path -> do+            when verbose $ putStrLn $ "Loading GI repository: " ++ path+            readFile def path+        Nothing -> do+            dataDirs <- girDataDirs+            error $ "Did not find a GI repository for " ++ (T.unpack name)+                ++ maybe "" ("-" ++) (T.unpack <$> version)+                ++ " in " ++ show dataDirs
+ src/GI/GIR/Signal.hs view
@@ -0,0 +1,26 @@+module GI.GIR.Signal+    ( Signal(..)+    , parseSignal+    ) where++import Data.Text (Text)++import GI.GIR.Callable (Callable(..), parseCallable)+import GI.GIR.Parser++data Signal = Signal {+        sigName :: Text,+        sigCallable :: Callable,+        sigDeprecated :: Maybe DeprecationInfo+    } deriving (Show, Eq)++parseSignal :: Parser Signal+parseSignal = do+  n <- getAttr "name"+  deprecated <- parseDeprecation+  callable <- parseCallable+  return $ Signal {+                sigName = n+              , sigCallable = callable+              , sigDeprecated = deprecated+              }
+ src/GI/GIR/Struct.hs view
@@ -0,0 +1,47 @@+-- | Parsing of structs.+module GI.GIR.Struct+    ( Struct(..)+    , parseStruct+    ) where++import Data.Text (Text)++import GI.GIR.Field (Field, parseFields)+import GI.GIR.Method (Method, MethodType(..), parseMethod)+import GI.GIR.Parser++data Struct = Struct {+    structIsBoxed :: Bool,+    structTypeInit :: Maybe Text,+    structSize :: Int,+    gtypeStructFor :: Maybe Name,+    -- https://bugzilla.gnome.org/show_bug.cgi?id=560248+    structIsDisguised :: Bool,+    structFields :: [Field],+    structMethods :: [(Name, Method)],+    structDeprecated :: Maybe DeprecationInfo }+    deriving Show++parseStruct :: Parser (Name, Struct)+parseStruct = do+  name <- parseName+  deprecated <- parseDeprecation+  structFor <- queryAttrWithNamespace GLibGIRNS "is-gtype-struct-for" >>= \case+               Just t -> (fmap Just . qualifyName) t+               Nothing -> return Nothing+  typeInit <- queryAttrWithNamespace GLibGIRNS "get-type"+  disguised <- optionalAttr "disguised" False parseBool+  fields <- parseFields+  constructors <- parseChildrenWithLocalName "constructor" (parseMethod Constructor)+  methods <- parseChildrenWithLocalName "method" (parseMethod OrdinaryMethod)+  return (name,+          Struct {+            structIsBoxed = error ("[boxed] unfixed struct " ++ show name)+          , structTypeInit = typeInit+          , structSize = error ("[size] unfixed struct " ++ show name)+          , gtypeStructFor = structFor+          , structIsDisguised = disguised+          , structFields = fields+          , structMethods = constructors ++ methods+          , structDeprecated = deprecated+          })
+ src/GI/GIR/Type.hs view
@@ -0,0 +1,162 @@+{-# LANGUAGE RecordWildCards, PatternGuards #-}+-- | Parsing type information from GIR files.+module GI.GIR.Type+    ( parseType+    ) where++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative ((<$>), (<*>))+#endif++import Data.Monoid ((<>))+import Data.Text (Text)+import qualified Data.Text as T+import Foreign.Storable (sizeOf)+import Foreign.C (CShort, CUShort, CInt, CUInt, CLong, CULong, CSize)+import System.Posix.Types (CSsize)++import GI.Type (Type(..), BasicType(..))+import GI.GIR.Parser++-- | Map the given type name to a BasicType (in GI.Type), if possible.+nameToBasicType :: Text -> Maybe BasicType+nameToBasicType "none"     = Just TVoid+-- XXX Should we try to distinguish TPtr from TVoid?+nameToBasicType "gpointer" = Just TVoid+nameToBasicType "gboolean" = Just TBoolean+nameToBasicType "gchar"    = Just TInt8+nameToBasicType "gint8"    = Just TInt8+nameToBasicType "guint8"   = Just TUInt8+nameToBasicType "gint16"   = Just TInt16+nameToBasicType "guint16"  = Just TUInt16+nameToBasicType "gint32"   = Just TInt32+nameToBasicType "guint32"  = Just TUInt32+nameToBasicType "gint64"   = Just TInt64+nameToBasicType "guint64"  = Just TUInt64+nameToBasicType "gfloat"   = Just TFloat+nameToBasicType "gdouble"  = Just TDouble+nameToBasicType "gunichar" = Just TUniChar+nameToBasicType "GType"    = Just TGType+nameToBasicType "utf8"     = Just TUTF8+nameToBasicType "filename" = Just TFileName+nameToBasicType "gshort"   = case sizeOf (0 :: CShort) of+                               2 -> Just TInt16+                               4 -> Just TInt32+                               8 -> Just TInt64+                               n -> error $ "Unexpected short size: " ++ show n+nameToBasicType "gushort"  = case sizeOf (0 :: CUShort) of+                               2 -> Just TUInt16+                               4 -> Just TUInt32+                               8 -> Just TUInt64+                               n -> error $ "Unexpected ushort size: " ++ show n+nameToBasicType "gint"     = case sizeOf (0 :: CInt) of+                               4 -> Just TInt32+                               8 -> Just TInt64+                               n -> error $ "Unexpected int length: " ++ show n+nameToBasicType "guint"    = case sizeOf (0 :: CUInt) of+                               4 -> Just TUInt32+                               8 -> Just TUInt64+                               n -> error $ "Unexpected uint length: " ++ show n+nameToBasicType "glong"    = case sizeOf (0 :: CLong) of+                               4 -> Just TInt32+                               8 -> Just TInt64+                               n -> error $ "Unexpected long length: " ++ show n+nameToBasicType "gulong"   = case sizeOf (0 :: CULong) of+                               4 -> Just TUInt32+                               8 -> Just TUInt64+                               n -> error $ "Unexpected ulong length: " ++ show n+nameToBasicType "gssize"   = case sizeOf (0 :: CSsize) of+                               4 -> Just TInt32+                               8 -> Just TInt64+                               n -> error $ "Unexpected ssize length: " ++ show n+nameToBasicType "gsize"    = case sizeOf (0 :: CSize) of+                               4 -> Just TUInt32+                               8 -> Just TUInt64+                               n -> error $ "Unexpected size length: " ++ show n+nameToBasicType _          = Nothing++-- | The different array types.+parseArrayInfo :: Parser Type+parseArrayInfo = queryAttr "name" >>= \case+      Just "GLib.Array" -> TGArray <$> parseType+      Just "GLib.PtrArray" -> TPtrArray <$> parseType+      Just "GLib.ByteArray" -> return TByteArray+      Just other -> parseError $ "Unsupported array type: \"" <> other <> "\""+      Nothing -> parseCArrayType++-- | A C array+parseCArrayType :: Parser Type+parseCArrayType = do+  zeroTerminated <- queryAttr "zero-terminated" >>= \case+                    Just b -> parseBool b+                    Nothing -> return True+  length <- queryAttr "length" >>= \case+            Just l -> parseIntegral l+            Nothing -> return (-1)+  fixedSize <- queryAttr "fixed-size" >>= \case+               Just s -> parseIntegral s+               Nothing -> return (-1)+  elementType <- parseType+  return $ TCArray zeroTerminated fixedSize length elementType++-- | A hash table.+parseHashTable :: Parser Type+parseHashTable = parseTypeElements >>= \case+                 [key, value] -> return $ TGHash key value+                 other -> parseError $ "Unsupported hash type: "+                                       <> T.pack (show other)++-- | For GLists and GSLists there is sometimes no information about+-- the type of the elements. In these cases we report them as+-- pointers.+parseListType :: Parser Type+parseListType = queryType >>= \case+                Just t -> return t+                Nothing -> return (TBasicType TVoid)++-- | A type which is not a BasicType or array.+parseFundamentalType :: Text -> Text -> Parser Type+parseFundamentalType "GLib" "List" = TGList <$> parseListType+parseFundamentalType "GLib" "SList" = TGSList <$> parseListType+parseFundamentalType "GLib" "HashTable" = parseHashTable+parseFundamentalType "GLib" "Error" = return TError+parseFundamentalType "GLib" "Variant" = return TVariant+parseFundamentalType "GObject" "ParamSpec" = return TParamSpec+-- A TInterface type (basically, everything that is not of a known type).+parseFundamentalType ns n = resolveQualifiedTypeName ns n++-- | Parse information on a "type" element.+parseTypeInfo :: Parser Type+parseTypeInfo = do+  typeName <- getAttr "name"+  case nameToBasicType typeName of+    Just b -> return (TBasicType b)+    Nothing -> case T.split ('.' ==) typeName of+                 [ns, n] -> parseFundamentalType ns n+                 [n] -> do+                   ns <- currentNamespace+                   parseFundamentalType ns n+                 _ -> parseError $ "Unsupported type form: \""+                                   <> typeName <> "\""++-- | Find the children giving the type of the given element.+parseTypeElements :: Parser [Type]+parseTypeElements = (++) <$> parseChildrenWithLocalName "type" parseTypeInfo <*>+                    parseChildrenWithLocalName "array" parseArrayInfo++-- | Try to find a type node, but do not error out if it is not+-- found. This _does_ give an error if more than one type node is+-- found.+queryType :: Parser (Maybe Type)+queryType = parseTypeElements >>= \case+            [e] -> return (Just e)+            [] -> return Nothing+            _ -> parseError $ "Found more than one type for the element."++-- | Parse the type of a node (which will be described by a child node+-- named "type" or "array").+parseType :: Parser Type+parseType = parseTypeElements >>= \case+            [e] -> return e+            [] -> parseError $ "Did not find a type for the element."+            _ -> parseError $ "Found more than one type for the element."
+ src/GI/GIR/Union.hs view
@@ -0,0 +1,40 @@+-- | Parsing of unions.+module GI.GIR.Union+    ( Union(..)+    , parseUnion+    ) where++import Data.Maybe (isJust)+import Data.Text (Text)++import GI.GIR.Field (Field, parseFields)+import GI.GIR.Method (Method, MethodType(..), parseMethod)+import GI.GIR.Parser++data Union = Union {+    unionIsBoxed :: Bool,+    unionSize :: Int,+    unionTypeInit :: Maybe Text,+    unionFields :: [Field],+    unionMethods :: [(Name, Method)],+    unionDeprecated :: Maybe DeprecationInfo }+    deriving Show++parseUnion :: Parser (Name, Union)+parseUnion = do+  name <- parseName+  deprecated <- parseDeprecation+  typeInit <- queryAttrWithNamespace GLibGIRNS "get-type"+  fields <- parseFields+  constructors <- parseChildrenWithLocalName "constructor" (parseMethod Constructor)+  methods <- parseChildrenWithLocalName "method" (parseMethod OrdinaryMethod)+  return (name,+          Union {+            unionIsBoxed = isJust typeInit+          , unionTypeInit = typeInit+          , unionSize = error ("unfixed union size " ++ show name)+          , unionFields = fields+          , unionMethods = constructors ++ methods+          , unionDeprecated = deprecated+          })+
+ src/GI/GIR/XMLUtils.hs view
@@ -0,0 +1,79 @@+-- | Some helpers for making traversals of GIR documents easier.+module GI.GIR.XMLUtils+    ( nodeToElement+    , subelements+    , localName+    , lookupAttr+    , GIRXMLNamespace(..)+    , lookupAttrWithNamespace+    , childElemsWithLocalName+    , childElemsWithNSName+    , firstChildWithLocalName+    , getElementContent+    ) where++import Text.XML (Element(elementNodes, elementName, elementAttributes),+                 Node(NodeContent, NodeElement), nameLocalName, Name(..))+import Data.Maybe (mapMaybe, listToMaybe)+import qualified Data.Map as M+import Data.Text (Text)++-- | Turn a node into an element (if it is indeed an element node).+nodeToElement :: Node -> Maybe Element+nodeToElement (NodeElement e) = Just e+nodeToElement _               = Nothing++-- | Find all children of the given element which are XML Elements+-- themselves.+subelements :: Element -> [Element]+subelements = mapMaybe nodeToElement . elementNodes++-- | The local name of an element.+localName :: Element -> Text+localName = nameLocalName . elementName++-- | Restrict to those with the given local name.+childElemsWithLocalName :: Text -> Element -> [Element]+childElemsWithLocalName n =+    filter localNameMatch . subelements+    where localNameMatch = (== n) . localName++-- | Restrict to those with given name.+childElemsWithNSName :: GIRXMLNamespace -> Text -> Element -> [Element]+childElemsWithNSName ns n = filter nameMatch . subelements+    where nameMatch = (== name) . elementName+          name = Name {+                   nameLocalName = n+                 , nameNamespace = Just (girNamespace ns)+                 , namePrefix = Nothing+                 }++-- | Find the first child element with the given name.+firstChildWithLocalName :: Text -> Element -> Maybe Element+firstChildWithLocalName n = listToMaybe . childElemsWithLocalName n++-- | Get the content of a given element, if it exists.+getElementContent :: Element -> Maybe Text+getElementContent = listToMaybe . mapMaybe getContent . elementNodes+    where getContent :: Node -> Maybe Text+          getContent (NodeContent t) = Just t+          getContent _ = Nothing++-- | Lookup an attribute for an element (with no prefix).+lookupAttr :: Name -> Element -> Maybe Text+lookupAttr attr element = M.lookup attr (elementAttributes element)++-- | GIR namespaces we know about.+data GIRXMLNamespace = GLibGIRNS | CGIRNS+                     deriving Show++-- | Return the text representation of the known GIR namespaces.+girNamespace :: GIRXMLNamespace -> Text+girNamespace GLibGIRNS = "http://www.gtk.org/introspection/glib/1.0"+girNamespace CGIRNS = "http://www.gtk.org/introspection/c/1.0"++-- | Lookup an attribute for an element, given the namespace where it lives.+lookupAttrWithNamespace :: GIRXMLNamespace -> Name -> Element -> Maybe Text+lookupAttrWithNamespace ns attr element =+    let attr' = attr {nameNamespace = Just (girNamespace ns)}+    in M.lookup attr' (elementAttributes element)
+ src/GI/GObject.hs view
@@ -0,0 +1,52 @@+module GI.GObject+    ( isGObject+    , apiIsGObject+    , nameIsGObject+    , isInitiallyUnowned+    , apiIsInitiallyUnowned+    ) where++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative ((<$>))+#endif++import GI.API+import GI.Code+import GI.Type++-- Returns whether the given type is a descendant of the given parent.+typeDoParentSearch :: Name -> Type -> CodeGen Bool+typeDoParentSearch parent (TInterface ns n) = findAPIByName name >>=+                                              apiDoParentSearch parent name+                                                  where name = Name ns n+typeDoParentSearch _ _ = return False++apiDoParentSearch :: Name -> Name -> API -> CodeGen Bool+apiDoParentSearch parent n api+    | parent == n = return True+    | otherwise   = case api of+      APIObject o ->+        case objParent o of+          Just (Name pns pn) -> typeDoParentSearch parent (TInterface pns pn)+          Nothing -> return False+      APIInterface iface ->+        do let prs = ifPrerequisites iface+           prereqs <- zip prs <$> mapM findAPIByName prs+           or <$> mapM (uncurry (apiDoParentSearch parent)) prereqs+      _ -> return False++isGObject :: Type -> CodeGen Bool+isGObject = typeDoParentSearch $ Name "GObject" "Object"++-- | Check whether the given name descends from GObject.+nameIsGObject :: Name -> CodeGen Bool+nameIsGObject n = findAPIByName n >>= apiIsGObject n++apiIsGObject :: Name -> API -> CodeGen Bool+apiIsGObject = apiDoParentSearch $ Name "GObject" "Object"++isInitiallyUnowned :: Type -> CodeGen Bool+isInitiallyUnowned = typeDoParentSearch $ Name "GObject" "InitiallyUnowned"++apiIsInitiallyUnowned :: Name -> API -> CodeGen Bool+apiIsInitiallyUnowned = apiDoParentSearch $ Name "GObject" "InitiallyUnowned"
+ src/GI/GType.hsc view
@@ -0,0 +1,24 @@+module GI.GType+    ( GType     -- Reexport from Data.GI.Base.BasicTypes for convenience+    , gtypeIsA+    , gtypeIsBoxed+    ) where++#include <glib-object.h>++import Foreign.C+import System.IO.Unsafe (unsafePerformIO)+import Data.GI.Base.BasicTypes (CGType, GType(..))++foreign import ccall unsafe "g_type_is_a" g_type_is_a ::+    CGType -> CGType -> IO CInt++gtypeIsA :: GType -> GType -> Bool+gtypeIsA (GType gtype) (GType is_a) = (/= 0) $+    unsafePerformIO $ g_type_is_a gtype is_a++gtypeBoxed :: GType+gtypeBoxed = GType #const G_TYPE_BOXED++gtypeIsBoxed :: GType -> Bool+gtypeIsBoxed gtype = gtypeIsA gtype gtypeBoxed
+ src/GI/Inheritance.hs view
@@ -0,0 +1,142 @@+{-# LANGUAGE ScopedTypeVariables #-}+module GI.Inheritance+    ( fullObjectPropertyList+    , fullInterfacePropertyList+    , fullObjectSignalList+    , fullInterfaceSignalList+    , instanceTree+    ) where++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative ((<$>), (<*>))+#endif+import Control.Monad (foldM)+import qualified Data.Map as M+import Data.Text (Text)++import GI.API+import GI.Code (findAPIByName, CodeGen, line)++-- | Find the parent of a given object when building the+-- instanceTree. For the purposes of the binding we do not need to+-- distinguish between GObject.Object and GObject.InitiallyUnowned.+getParent :: API -> Maybe Name+getParent (APIObject o) = rename $ objParent o+    where+      rename :: Maybe Name -> Maybe Name+      rename (Just (Name "GObject" "InitiallyUnowned")) =+          Just (Name "GObject" "Object")+      rename x = x+getParent _ = Nothing++-- | Compute the (ordered) list of parents of the current object.+instanceTree :: Name -> CodeGen [Name]+instanceTree n = do+  api <- findAPIByName n+  case getParent api of+    Just p -> (p :) <$> instanceTree p+    Nothing -> return []++-- A class for qualities of an object/interface that it inherits from+-- its ancestors. Properties and Signals are two classes of interest.+class Inheritable i where+    ifInheritables :: Interface -> [i]+    objInheritables :: Object -> [i]+    iName :: i -> Text++instance Inheritable Property where+    ifInheritables = ifProperties+    objInheritables = objProperties+    iName = propName++instance Inheritable Signal where+    ifInheritables = ifSignals+    objInheritables = objSignals+    iName = sigName++-- Returns a list of all inheritables defined for this object+-- (including those defined by its ancestors and the interfaces it+-- implements), together with the name of the interface defining the+-- property.+apiInheritables :: Inheritable i => Name -> CodeGen [(Name, i)]+apiInheritables n = do+  api <- findAPIByName n+  case api of+    APIInterface iface -> return $ map ((,) n) (ifInheritables iface)+    APIObject object -> return $ map ((,) n) (objInheritables object)+    _ -> error $ "apiInheritables : Unexpected API : " ++ show n++fullAPIInheritableList :: Inheritable i => Name -> CodeGen [(Name, i)]+fullAPIInheritableList n = do+  api <- findAPIByName n+  case api of+    APIInterface iface -> fullInterfaceInheritableList n iface+    APIObject object -> fullObjectInheritableList n object+    _ -> error $ "FullAPIInheritableList : Unexpected API : " ++ show n++fullObjectInheritableList :: Inheritable i => Name -> Object ->+                             CodeGen [(Name, i)]+fullObjectInheritableList n obj = do+  iT <- instanceTree n+  (++) <$> (concat <$> mapM apiInheritables (n : iT))+       <*> (concat <$> mapM apiInheritables (objInterfaces obj))++fullInterfaceInheritableList :: Inheritable i => Name -> Interface ->+                                CodeGen [(Name, i)]+fullInterfaceInheritableList n iface =+  (++) (map ((,) n) (ifInheritables iface))+    <$> (concat <$> mapM fullAPIInheritableList (ifPrerequisites iface))++-- It is sometimes the case that a property name or signal is defined+-- both in an object and in one of its ancestors/implemented+-- interfaces. This is harmless if the properties are isomorphic+-- (there will be more than one qualified set of property+-- setters/getters that we can call, but they are all isomorphic). If+-- they are not isomorphic we refuse to set either, and print a+-- warning in the generated code.+removeDuplicates :: forall i. (Eq i, Show i, Inheritable i) =>+                        [(Name, i)] -> CodeGen [(Name, i)]+removeDuplicates inheritables =+    (filterTainted . M.toList) <$> foldM filterDups M.empty inheritables+    where+      filterDups :: M.Map Text (Bool, Name, i) -> (Name, i) ->+                    CodeGen (M.Map Text (Bool, Name, i))+      filterDups m (name, prop) =+        case M.lookup (iName prop) m of+          Just (tainted, n, p)+              | tainted     -> return m+              | (p == prop) -> return m -- Duplicated, but isomorphic property+              | otherwise   ->+                do line   "--- XXX Duplicated object with different types:"+                   line $ "  --- " ++ show n ++ " -> " ++ show p+                   line $ "  --- " ++ show name ++ " -> " ++ show prop+                   -- Tainted+                   return $ M.insert (iName prop) (True, n, p) m+          Nothing -> return $ M.insert (iName prop) (False, name, prop) m+      filterTainted :: [(Text, (Bool, Name, i))] -> [(Name, i)]+      filterTainted xs =+          [(name, prop) | (_, (tainted, name, prop)) <- xs, not tainted]++-- | List all properties defined for an object, including those+-- defined by its ancestors.+fullObjectPropertyList :: Name -> Object -> CodeGen [(Name, Property)]+fullObjectPropertyList n o = fullObjectInheritableList n o >>=+                         removeDuplicates++-- | List all properties defined for an interface, including those+-- defined by its prerequisites.+fullInterfacePropertyList :: Name -> Interface -> CodeGen [(Name, Property)]+fullInterfacePropertyList n i = fullInterfaceInheritableList n i >>=+                            removeDuplicates++-- | List all signals defined for an object, including those+-- defined by its ancestors.+fullObjectSignalList :: Name -> Object -> CodeGen [(Name, Signal)]+fullObjectSignalList n o = fullObjectInheritableList n o >>=+                           removeDuplicates++-- | List all signals defined for an interface, including those+-- defined by its prerequisites.+fullInterfaceSignalList :: Name -> Interface -> CodeGen [(Name, Signal)]+fullInterfaceSignalList n i = fullInterfaceInheritableList n i >>=+                              removeDuplicates
+ src/GI/LibGIRepository.hs view
@@ -0,0 +1,150 @@+{-# LANGUAGE ScopedTypeVariables #-}+-- | A minimal wrapper for libgirepository.+module GI.LibGIRepository+    ( girRequire+    , girStructSizeAndOffsets+    , girUnionSizeAndOffsets+    , girLoadGType+    ) where++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative ((<$>))+#endif++import Control.Monad (forM, when)+import qualified Data.Map as M+import Data.Text (Text)+import qualified Data.Text as T++import Foreign.C.Types (CInt(..), CSize(..))+import Foreign.C.String (CString)+import Foreign (nullPtr, Ptr, ForeignPtr, FunPtr, peek)++import Data.GI.Base.BasicConversions (withTextCString, cstringToText)+import Data.GI.Base.BasicTypes (BoxedObject(..), GType(..), CGType)+import Data.GI.Base.GError (GError, checkGError)+import Data.GI.Base.ManagedPtr (wrapBoxed, withManagedPtr)+import Data.GI.Base.Utils (allocMem, freeMem)++-- | Wrapper for 'GIBaseInfo'+newtype BaseInfo = BaseInfo (ForeignPtr BaseInfo)++-- | Wrapper for 'GITypelib'+newtype Typelib = Typelib (Ptr Typelib)++foreign import ccall "g_base_info_gtype_get_type" c_g_base_info_gtype_get_type :: IO GType++instance BoxedObject BaseInfo where+    boxedType _ = c_g_base_info_gtype_get_type++foreign import ccall "g_irepository_require" g_irepository_require ::+    Ptr () -> CString -> CString -> CInt -> Ptr (Ptr GError)+    -> IO (Ptr Typelib)++-- | Ensure that the given version of the namespace is loaded. If that+-- is not possible we error out.+girRequire :: Text -> Text -> IO Typelib+girRequire ns version =+    withTextCString ns $ \cns ->+    withTextCString version $ \cversion -> do+        typelib <- checkGError (g_irepository_require nullPtr cns cversion 0)+                               (error $ "Could not load typelib for "+                                          ++ show ns ++ " version "+                                          ++ show version)+        return (Typelib typelib)++foreign import ccall "g_irepository_find_by_name" g_irepository_find_by_name ::+    Ptr () -> CString -> CString -> IO (Ptr BaseInfo)++-- | Find a given baseinfo by name, or give an error if it cannot be+-- found.+girFindByName :: Text -> Text -> IO BaseInfo+girFindByName ns name =+    withTextCString ns $ \cns ->+    withTextCString name $ \cname -> do+      ptr <- g_irepository_find_by_name nullPtr cns cname+      if ptr == nullPtr+      then error ("Could not find " ++ T.unpack ns ++ "::" ++ T.unpack name)+      else wrapBoxed BaseInfo ptr++foreign import ccall "g_field_info_get_offset" g_field_info_get_offset ::+    Ptr BaseInfo -> IO CInt+foreign import ccall "g_base_info_get_name" g_base_info_get_name ::+    Ptr BaseInfo -> IO CString++foreign import ccall "g_struct_info_get_size" g_struct_info_get_size ::+    Ptr BaseInfo -> IO CSize+foreign import ccall "g_struct_info_get_n_fields" g_struct_info_get_n_fields ::+    Ptr BaseInfo -> IO CInt+foreign import ccall "g_struct_info_get_field" g_struct_info_get_field ::+    Ptr BaseInfo -> CInt -> IO (Ptr BaseInfo)++-- | Find out the size of a struct, and the map from field names to+-- offsets inside the struct.+girStructSizeAndOffsets :: Text -> Text -> IO (Int, M.Map Text Int)+girStructSizeAndOffsets ns name = do+  baseinfo <- girFindByName ns name+  withManagedPtr baseinfo $ \si -> do+     size <- g_struct_info_get_size si+     nfields <- g_struct_info_get_n_fields si+     fieldOffsets <- forM [0..(nfields-1)] $ \i -> do+                       fieldInfo <- (g_struct_info_get_field si i+                                     >>= wrapBoxed BaseInfo)+                       withManagedPtr fieldInfo $ \fi -> do+                         fname <- (g_base_info_get_name fi >>= cstringToText)+                         fOffset <- g_field_info_get_offset fi+                         return (fname, fromIntegral fOffset)+     return (fromIntegral size, M.fromList fieldOffsets)++foreign import ccall "g_union_info_get_size" g_union_info_get_size ::+    Ptr BaseInfo -> IO CSize+foreign import ccall "g_union_info_get_n_fields" g_union_info_get_n_fields ::+    Ptr BaseInfo -> IO CInt+foreign import ccall "g_union_info_get_field" g_union_info_get_field ::+    Ptr BaseInfo -> CInt -> IO (Ptr BaseInfo)++-- | Find out the size of a union, and the map from field names to+-- offsets inside the union.+girUnionSizeAndOffsets :: Text -> Text -> IO (Int, M.Map Text Int)+girUnionSizeAndOffsets ns name = do+  baseinfo <- girFindByName ns name+  withManagedPtr baseinfo $ \ui -> do+     size <- g_union_info_get_size ui+     nfields <- g_union_info_get_n_fields ui+     fieldOffsets <- forM [0..(nfields-1)] $ \i -> do+                       fieldInfo <- (g_union_info_get_field ui i+                                     >>= wrapBoxed BaseInfo)+                       withManagedPtr fieldInfo $ \fi -> do+                         fname <- (g_base_info_get_name fi >>= cstringToText)+                         fOffset <- g_field_info_get_offset fi+                         return (fname, fromIntegral fOffset)+     return (fromIntegral size, M.fromList fieldOffsets)++foreign import ccall "g_typelib_symbol" g_typelib_symbol ::+    Ptr Typelib -> CString -> Ptr (FunPtr a) -> IO CInt++-- | Load a symbol from the dynamic library associated to the given namespace.+girSymbol :: forall a. Text -> Text -> IO (FunPtr a)+girSymbol ns symbol = do+  typelib <- withTextCString ns $ \cns ->+                    checkGError (g_irepository_require nullPtr cns nullPtr 0)+                                (error $ "Could not load typelib " ++ show ns)+  funPtrPtr <- allocMem :: IO (Ptr (FunPtr a))+  result <- withTextCString symbol $ \csymbol ->+                      g_typelib_symbol typelib csymbol funPtrPtr+  when (result /= 1) $+       error ("Could not resolve symbol " ++ show symbol ++ " in namespace "+              ++ show ns)+  funPtr <- peek funPtrPtr+  freeMem funPtrPtr+  return funPtr++type GTypeInit = IO CGType+foreign import ccall "dynamic" gtypeInit :: FunPtr GTypeInit -> GTypeInit++-- | Load a GType given the namespace where it lives and the type init+-- function.+girLoadGType :: Text -> Text -> IO GType+girLoadGType ns typeInit = do+  funPtr <- girSymbol ns typeInit+  GType <$> gtypeInit funPtr
+ src/GI/OverloadedSignals.hs view
@@ -0,0 +1,171 @@+module GI.OverloadedSignals+    ( genSignalInstances+    , genOverloadedSignalConnectors+    ) where++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative ((<$>))+#endif+import Control.Monad (forM_, when)+import Control.Monad.Writer (tell)+import Data.Text (Text)+import qualified Data.Text as T++import Data.List (intercalate)+import qualified Data.Set as S++import GI.API+import GI.Code+import GI.Inheritance (fullObjectSignalList, fullInterfaceSignalList)+import GI.GObject (apiIsGObject)+import GI.Signal (signalHaskellName)+import GI.SymbolNaming (ucFirst, upperName)+import GI.Util (padTo)++-- A list of distinct signal names for all GObjects appearing in the+-- given list of APIs.+findSignalNames :: [(Name, API)] -> CodeGen [String]+findSignalNames apis = (map T.unpack . S.toList) <$> go apis S.empty+    where+      go :: [(Name, API)] -> S.Set Text -> CodeGen (S.Set Text)+      go [] set = return set+      go ((_, api):apis) set =+          case api of+            APIInterface iface ->+                go apis $ insertSignals (ifSignals iface) set+            APIObject object ->+                go apis $ insertSignals (objSignals object) set+            _ -> go apis set++      insertSignals :: [Signal] -> S.Set Text -> S.Set Text+      insertSignals props set = foldr (S.insert . sigName) set props++-- | Generate the overloaded signal connectors: "Clicked", "ActivateLink", ...+genOverloadedSignalConnectors :: [(Name, API)] -> String -> CodeGen ()+genOverloadedSignalConnectors allAPIs modulePrefix = do+  line   "-- Generated code."+  blank+  line   "{-# LANGUAGE DataKinds, GADTs, KindSignatures, FlexibleInstances #-}"+  blank+  line $ "module " ++ modulePrefix ++ "Signals where"+  blank+  line   "import GHC.TypeLits"+  line   "import GHC.Exts (Constraint)"+  blank+  line   "class NoConstraint a"+  line   "instance NoConstraint a"+  blank+  line   "data SignalProxy (a :: Symbol) (b :: Symbol) (c :: * -> Constraint) where"+  indent $ do+    signalNames <- findSignalNames allAPIs+    let maxLength = maximum $ map (length . signalHaskellName) signalNames+    forM_ signalNames $ \sn ->+        line $ padTo (maxLength + 1) (ucFirst (signalHaskellName sn)) +++                 ":: SignalProxy \"" ++ sn ++ "\" \"\" NoConstraint"++-- | Qualified name for the "(sigName, info)" tag for a given signal.+signalInfoName :: Name -> Signal -> CodeGen String+signalInfoName n signal = do+  n' <- upperName n+  return $ n' ++ (ucFirst . signalHaskellName . T.unpack . sigName) signal+             ++ "SignalInfo"++-- | Generate the given signal instance for the given API object.+genInstance :: Name -> Signal -> CodeGen ()+genInstance owner signal = group $ do+  name <- upperName owner+  let sn = (ucFirst . signalHaskellName . T.unpack . sigName) signal+  si <- signalInfoName owner signal+  line $ "data " ++ si+  line $ "instance SignalInfo " ++ si ++ " where"+  indent $ do+      let signalConnectorName = name ++ sn+          cbHaskellType = signalConnectorName ++ "Callback"+      line $ "type HaskellCallbackType " ++ si ++ " = " ++ cbHaskellType+      line $ "connectSignal _ = " ++ "connect" ++ name ++ sn++-- | Signal instances for (GObject-derived) objects.+genObjectSignals :: Name -> Object -> CodeGen ()+genObjectSignals n o = do+  name <- upperName n+  isGO <- apiIsGObject n (APIObject o)+  when isGO $ do+       mapM_ (genInstance n) (objSignals o)+       infos <- fullObjectSignalList n o >>=+                mapM (\(owner, signal) -> do+                      si <- signalInfoName owner signal+                      return $ "'(\"" ++ (T.unpack . sigName) signal+                                 ++ "\", " ++ si ++ ")")+       -- The "notify::[property]" signal is a generic signal used for+       -- connecting to property notifications.+       let allSignals = infos +++                        ["'(\"notify::[property]\", GObjectNotifySignalInfo)"]+       group . line $ "type instance SignalList " ++ name +++             " = '[ " ++ intercalate ", " allSignals ++ "]"++-- | Signal instances for interfaces.+genInterfaceSignals :: Name -> Interface -> CodeGen ()+genInterfaceSignals n iface = do+  name <- upperName n+  mapM_ (genInstance n) (ifSignals iface)+  infos <- fullInterfaceSignalList n iface >>=+           mapM (\(owner, signal) -> do+                   si <- signalInfoName owner signal+                   return $ "'(\"" ++ T.unpack (sigName signal)+                              ++ "\", " ++ si ++ ")")+  isGO <- apiIsGObject n (APIInterface iface)+  -- The "notify::[property]" signal is a generic signal used for+  -- connecting to property notifications of a GObject.+  let allSignals =+          if isGO+          then infos ++ ["'(\"notify::[property]\", GObjectNotifySignalInfo)"]+          else infos+  group . line $ "type instance SignalList " ++ name +++            " = '[ " ++ intercalate ", " allSignals ++ "]"++-- | Generate HasSignal instances for a given API element.+genSignals :: (Name, API) -> CodeGen ()+genSignals (n, APIObject o) = genObjectSignals n o+genSignals (n, APIInterface i) = genInterfaceSignals n i+genSignals _ = return ()++-- | Generate the signal information instances, so the generic overloaded+-- signal connectors are available.+genSignalInstances :: String -> [(Name, API)] -> String -> CodeGen ()+genSignalInstances name apis modulePrefix = do+  let mp = (modulePrefix ++)+      nm = ucFirst name++  code <- recurse' $ forM_ apis genSignals++  line   "-- Generated code."+  blank++  -- Providing orphan instances is the whole point of these modules,+  -- tell GHC that this is fine.+  line   "{-# OPTIONS_GHC -fno-warn-orphans #-}"+  blank+  line   "{-# LANGUAGE DataKinds,    FlexibleInstances,"+  line   "             TypeFamilies, MultiParamTypeClasses,"+  line "               TypeOperators #-}"+  blank++  line $ "module " ++ mp nm ++ "Signals where"+  blank++  line   "import Data.GI.Base.Properties (GObjectNotifySignalInfo)"+  line   "import Data.GI.Base.Signals"+  line   "import Data.GI.Base.Overloading"+  blank++  -- Import dependencies, including instances for their overloaded+  -- signals, so they are implicitly reexported and they do not need+  -- to be included explicitly from client code.+  deps <- S.toList <$> getDeps+  forM_ deps $ \i -> when (i /= name) $+    line $ "import qualified " ++ mp (ucFirst i) ++ "Signals as " ++ ucFirst i++  line $ "import " ++ modulePrefix ++ nm+  blank++  tell code
+ src/GI/Overrides.hs view
@@ -0,0 +1,199 @@+{-# LANGUAGE ViewPatterns #-}+module GI.Overrides+    ( Overrides(pkgConfigMap, cabalPkgVersion, nsChooseVersion)+    , parseOverridesFile+    , filterAPIsAndDeps+    ) where++import Control.Monad.Except+import Control.Monad.State+import Control.Monad.Writer++import Data.Maybe (fromMaybe, isJust)+import qualified Data.Map as M+import qualified Data.Set as S+import qualified Data.Text as T+import Data.Text (Text)++import GI.API++data Overrides = Overrides {+      -- | Prefix for constants in a given namespace, if not given the+      -- "_" string will be used.+      constantPrefix  :: M.Map String String,+      -- | Ignored elements of a given API.+      ignoredElems    :: M.Map Name (S.Set Text),+      -- | Ignored APIs (all elements in this API will just be discarded).+      ignoredAPIs     :: S.Set Name,+      -- | Structs for which accessors should not be auto-generated.+      sealedStructs   :: S.Set Name,+      -- | Mapping from GObject Introspection namespaces to pkg-config+      pkgConfigMap    :: M.Map Text Text,+      -- | Version number for the generated .cabal package.+      cabalPkgVersion :: Maybe Text,+      -- | Prefered version of the namespace+      nsChooseVersion :: M.Map String String+}++-- | Construct the generic config for a module.+defaultOverrides :: Overrides+defaultOverrides = Overrides {+              constantPrefix  = M.empty,+              ignoredElems    = M.empty,+              ignoredAPIs     = S.empty,+              sealedStructs   = S.empty,+              pkgConfigMap    = M.empty,+              cabalPkgVersion = Nothing,+              nsChooseVersion = M.empty }++-- | There is a sensible notion of zero and addition of Overridess,+-- encode this so that we can view the parser as a writer monad of+-- configs.+instance Monoid Overrides where+    mempty = defaultOverrides+    mappend a b = Overrides {+      constantPrefix = constantPrefix a <> constantPrefix b,+      ignoredAPIs = ignoredAPIs a <> ignoredAPIs b,+      sealedStructs = sealedStructs a <> sealedStructs b,+      ignoredElems = M.unionWith S.union (ignoredElems a) (ignoredElems b),+      pkgConfigMap = pkgConfigMap a <> pkgConfigMap b,+      cabalPkgVersion = if isJust (cabalPkgVersion b)+                        then cabalPkgVersion b+                        else cabalPkgVersion a,+      nsChooseVersion = nsChooseVersion a <> nsChooseVersion b+    }++-- | We have a bit of context (the current namespace), and can fail,+-- encode this in a monad.+type Parser = WriterT Overrides (StateT (Maybe String) (Except Text)) ()++-- | Parse the given config file (as a set of lines) for a given+-- introspection namespace, filling in the configuration as needed. In+-- case the parsing fails we return a description of the error+-- instead.+parseOverridesFile :: [Text] -> Either Text Overrides+parseOverridesFile ls = runExcept $ flip evalStateT Nothing $ execWriterT $+                                    mapM (parseOneLine . T.strip) ls++-- | Parse a single line of the config file, modifying the+-- configuration as appropriate.+parseOneLine :: Text -> Parser+-- Empty lines+parseOneLine line | T.null line = return ()+-- Comments+parseOneLine (T.stripPrefix "#" -> Just _) = return ()+parseOneLine (T.stripPrefix "namespace " -> Just ns) =+    (put . Just . T.unpack . T.strip) ns+parseOneLine (T.stripPrefix "ignore " -> Just ign) = get >>= parseIgnore ign+parseOneLine (T.stripPrefix "constantPrefix " -> Just p) = get >>= parseConstP p+parseOneLine (T.stripPrefix "seal " -> Just s) = get >>= parseSeal s+parseOneLine (T.stripPrefix "pkg-config-name" -> Just s) = parsePkgConfigName s+parseOneLine (T.stripPrefix "cabal-pkg-version" -> Just s) = parseCabalPkgVersion s+parseOneLine (T.stripPrefix "namespace-version" -> Just s) = parseNsVersion s+parseOneLine l = throwError $ "Could not understand \"" <> l <> "\"."++-- | Ignored elements.+parseIgnore :: Text -> Maybe String -> Parser+parseIgnore _ Nothing =+    throwError "'ignore' requires a namespace to be defined first."+parseIgnore (T.words -> [T.splitOn "." -> [api,elem]]) (Just ns) =+    tell $ defaultOverrides {ignoredElems = M.singleton (Name ns (T.unpack api))+                                         (S.singleton elem)}+parseIgnore (T.words -> [T.splitOn "." -> [api]]) (Just ns) =+    tell $ defaultOverrides {ignoredAPIs = S.singleton (Name ns (T.unpack api))}+parseIgnore ignore _ =+    throwError ("Ignore syntax is of the form \"ignore API.elem\" with '.elem' optional.\nGot \"ignore " <> ignore <> "\" instead.")++-- | Prefix for constants.+parseConstP :: Text -> Maybe String -> Parser+parseConstP _ Nothing = throwError "'constantPrefix' requires a namespace to be defined first. "+parseConstP (T.words -> [p]) (Just ns) = tell $+    defaultOverrides {constantPrefix = M.singleton ns (T.unpack p)}+parseConstP prefix _ =+    throwError ("constantPrefix syntax is of the form \"constantPrefix prefix\".\nGot \"constantPrefix " <> prefix <> "\" instead.")++-- | Sealed structures.+parseSeal :: Text -> Maybe String -> Parser+parseSeal _ Nothing = throwError "'seal' requires a namespace to be defined first."+parseSeal (T.words -> [s]) (Just ns) = tell $+    defaultOverrides {sealedStructs = S.singleton (Name ns (T.unpack s))}+parseSeal seal _ =+    throwError ("seal syntax is of the form \"seal name\".\nGot \"seal "+                <> seal <> "\" instead.")++-- | Mapping from GObject Introspection namespaces to pkg-config.+parsePkgConfigName :: Text -> Parser+parsePkgConfigName (T.words -> [gi,pc]) = tell $+    defaultOverrides {pkgConfigMap =+                          M.singleton (T.toLower gi) pc}+parsePkgConfigName t =+    throwError ("pkg-config-name syntax is of the form\n" <>+                "\t\"pkg-config-name gi-namespace pk-name\"\n" <>+                "Got \"pkg-config-name " <> t <> "\" instead.")++-- | Choose a preferred namespace version to load.+parseNsVersion :: Text -> Parser+parseNsVersion (T.words -> [ns,version]) = tell $+    defaultOverrides {nsChooseVersion =+                          M.singleton (T.unpack ns) (T.unpack version)}+parseNsVersion t =+    throwError ("namespace-version syntax is of the form\n" <>+                "\t\"namespace-version namespace version\"\n" <>+                "Got \"namespace-version " <> t <> "\" instead.")++-- | Specifying the cabal package version by hand.+parseCabalPkgVersion :: Text -> Parser+parseCabalPkgVersion (T.words -> [version]) = tell $+    defaultOverrides {cabalPkgVersion = Just version}+parseCabalPkgVersion t =+    throwError ("cabal-pkg-version syntax is of the form\n" <>+               "\t\"cabal-pkg-version version\"\n" <>+               "Got \"cabal-pkg-version " <> t <> "\" instead.")++-- | Filter a set of named objects based on a lookup list of names to+-- ignore.+filterNamed :: [(Name, a)] -> S.Set Text -> [(Name, a)]+filterNamed set ignores =+    filter ((`S.notMember` ignores) . T.pack . name . fst) set++-- | Filter one API according to the given config.+filterOneAPI :: Overrides -> (Name, API, Maybe (S.Set Text)) -> (Name, API)+filterOneAPI ovs (Name ns n, APIConst c, _) =+    (Name ns (prefix ++ n), APIConst c)+    where prefix = fromMaybe "_" $ M.lookup ns (constantPrefix ovs)+filterOneAPI ovs (n, APIStruct s, maybeIgnores) =+    (n, APIStruct s {structMethods = maybe (structMethods s)+                                     (filterNamed (structMethods s))+                                     maybeIgnores,+                     structFields = if n `S.member` sealedStructs ovs+                                    then []+                                    else structFields s})+-- The rest only apply if there are ignores.+filterOneAPI _ (n, api, Nothing) = (n, api)+filterOneAPI _ (n, APIObject o, Just ignores) =+    (n, APIObject o {objMethods = filterNamed (objMethods o) ignores,+                     objSignals = filter ((`S.notMember` ignores) . sigName)+                                  (objSignals o)+                    })+filterOneAPI _ (n, APIInterface i, Just ignores) =+    (n, APIInterface i {ifMethods = filterNamed (ifMethods i) ignores,+                        ifSignals = filter ((`S.notMember` ignores) . sigName)+                                    (ifSignals i)+                       })+filterOneAPI _ (n, APIUnion u, Just ignores) =+    (n, APIUnion u {unionMethods = filterNamed (unionMethods u) ignores})+filterOneAPI _ (n, api, _) = (n, api)++-- | Given a list of APIs modify them according to the given config.+filterAPIs :: Overrides -> [(Name, API)] -> [(Name, API)]+filterAPIs ovs apis = map (filterOneAPI ovs . fetchIgnores) filtered+    where filtered = filter ((`S.notMember` ignoredAPIs ovs) . fst) apis+          fetchIgnores (n, api) = (n, api, M.lookup n (ignoredElems ovs))++-- | Load a given API, applying filtering. Load also any necessary+-- dependencies.+filterAPIsAndDeps :: Overrides -> GIRInfo -> [GIRInfo]+                  -> (M.Map Name API, M.Map Name API)+filterAPIsAndDeps ovs doc deps =+  let toMap = M.fromList . filterAPIs ovs . girAPIs+  in (toMap doc, M.unions (map toMap deps))
+ src/GI/PkgConfig.hs view
@@ -0,0 +1,47 @@+module GI.PkgConfig+    ( pkgConfigGetVersion+    ) where++import Control.Monad (when)+import Data.Monoid (First(..), (<>))+#if !MIN_VERSION_base(4,8,0)+import Data.Monoid (mconcat)+#endif+import qualified Data.Map.Strict as M+import qualified Data.Text as T+import Data.Text (Text)+import System.Exit (ExitCode(..))+import System.Process (readProcessWithExitCode)++-- | Try asking pkg-config for the version of a given module.+tryPkgConfig :: Text -> IO (Maybe (Text, Text))+tryPkgConfig pkgName = do+  (exitcode, stdout, _) <-+      readProcessWithExitCode "pkg-config" ["--modversion", T.unpack pkgName] ""+  case exitcode of+    ExitSuccess -> case lines stdout of+                     [v] -> return (Just (pkgName, T.pack v))+                     _ -> return Nothing+    ExitFailure _ -> return Nothing++-- | Get the pkg-config name and associated installed version of a given+-- gobject-introspection namespace. Since the mapping is not+-- one-to-one some guessing is involved, although in most cases the+-- required information is listed in the GIR file.+pkgConfigGetVersion :: Text     -- name+                    -> Text     -- version+                    -> [Text]   -- known package names+                    -> Bool     -- verbose+                    -> M.Map Text Text -- suggested overrides+                    -> IO (Maybe (Text, Text))+pkgConfigGetVersion name version packages verbose overridenNames = do+  let lowerName = T.toLower name+  when verbose $+           putStrLn $ T.unpack ("Querying pkg-config for " <> name <>+                              " version " <> version)+  let alternatives = case M.lookup lowerName overridenNames of+                       Nothing -> packages ++ [lowerName <> "-" <> version,+                                               lowerName]+                       Just n -> [n <> "-" <> version, n]+      firstJust = getFirst . mconcat . map First+  mapM tryPkgConfig alternatives >>= return . firstJust
+ src/GI/ProjectInfo.hs view
@@ -0,0 +1,27 @@+{-# LANGUAGE TemplateHaskell #-}+-- | Project information to include in generated bindings, should be+-- kept in sync with haskell-gi.cabal+module GI.ProjectInfo+    ( homepage+    , authors+    , license+    , licenseText+    , maintainers+    ) where++import Data.FileEmbed (embedStringFile)++homepage :: String+homepage = "https://github.com/haskell-gi/haskell-gi"++authors :: String+authors = "Will Thompson, Iñaki García Etxebarria and Jonas Platte"++maintainers :: String+maintainers = "Iñaki García Etxebarria (garetxe@gmail.com)"++license :: String+license = "LGPL-2.1"++licenseText :: String+licenseText = $(embedStringFile "LICENSE")
+ src/GI/Properties.hs view
@@ -0,0 +1,280 @@+module GI.Properties+    ( genInterfaceProperties+    , genObjectProperties+    ) where++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative ((<$>))+#endif+import Control.Monad (forM_, when, unless)+import Data.List (intercalate)+import Data.Monoid ((<>))+import qualified Data.Text as T++import Foreign.Storable (sizeOf)+import Foreign.C (CInt, CUInt)++import GI.API+import GI.Conversions+import GI.Code+import GI.GObject+import GI.Inheritance (fullObjectPropertyList, fullInterfacePropertyList)+import GI.SymbolNaming (upperNameWithSuffix, upperName, classConstraint, qualifyWithSuffix, hyphensToCamelCase)+import GI.Type+import GI.Util++propTypeStr :: Type -> CodeGen String+propTypeStr t = case t of+   TBasicType TUTF8 -> return "String"+   TBasicType TFileName -> return "String"+   TBasicType TVoid -> return "Ptr"+   TByteArray -> return "ByteArray"+   TGHash _ _ -> return "Hash"+   TVariant -> return "Variant"+   TParamSpec -> return "ParamSpec"+   TBasicType TInt32 -> do+     -- This should work for all systems in common use, but rather+     -- than leaving the assumption implicit better double checking.+     when (sizeOf (0 :: CInt) /= 4) $+          error "C Integers are not 4 bytes, unsupported platform."+     return "CInt"+   TBasicType TUInt32 -> do+     when (sizeOf (0 :: CUInt) /= 4) $+          error "C Integers are not 4 bytes, unsupported platform."+     return "CUInt"+   TBasicType TInt64 -> return "Int64"+   TBasicType TUInt64 -> return "UInt64"+   TBasicType TBoolean -> return "Bool"+   TBasicType TFloat -> return "Float"+   TBasicType TDouble -> return "Double"+   TBasicType TGType -> return "GType"+   TCArray True _ _ (TBasicType TUTF8) -> return "StringArray"+   TCArray True _ _ (TBasicType TFileName) -> return "StringArray"+   TGList (TBasicType TVoid) -> return "PtrGList"+   t@(TInterface ns n) -> do+     api <- findAPIByName (Name ns n)+     case api of+       APIEnum _ -> return "Enum"+       APIFlags _ -> return "Flags"+       APIStruct s -> if structIsBoxed s+                      then return "Boxed"+                      else error $ "Unboxed struct property : " ++ show t+       APIUnion u -> if unionIsBoxed u+                     then return "Boxed"+                     else error $ "Unboxed union property : " ++ show t+       APIObject _ -> do+                isGO <- isGObject t+                if isGO+                then return "Object"+                else error $ "Non-GObject object property : " ++ show t+       APIInterface _ -> do+                isGO <- isGObject t+                if isGO+                then return "Object"+                else error $ "Non-GObject interface property : " ++ show t+       _ -> error $ "Unknown interface property of type : " ++ show t+   _ -> error $ "Don't know how to handle properties of type " ++ show t++-- Given a property, return the set of constraints on the types, and+-- the type variables for the object and its value.+attrType :: Property -> CodeGen ([String], String)+attrType prop = do+  (_,t,constraints) <- argumentType ['a'..'l'] $ propType prop+  if ' ' `elem` t+  then return (constraints, parenthesize t)+  else return (constraints, t)++genPropertySetter :: Name -> String -> Property -> CodeGen ()+genPropertySetter n pName prop = group $ do+  oName <- upperName n+  (constraints, t) <- attrType prop+  let constraints' = "MonadIO m":(classConstraint oName ++ " o"):constraints+  tStr <- propTypeStr $ propType prop+  line $ "set" ++ pName ++ " :: (" ++ intercalate ", " constraints'+           ++ ") => o -> " ++ t ++ " -> m ()"+  line $ "set" ++ pName ++ " obj val = liftIO $ setObjectProperty" ++ tStr+           ++ " obj \"" ++ T.unpack (propName prop) ++ "\" val"++genPropertyGetter :: Name -> String -> Property -> CodeGen ()+genPropertyGetter n pName prop = group $ do+  oName <- upperName n+  outType <- haskellType (propType prop)+  let constraints = "(MonadIO m, " ++ classConstraint oName ++ " o)"+  line $ "get" ++ pName ++ " :: " ++ constraints +++                " => o -> " ++ show ("m" `con` [outType])+  tStr <- propTypeStr $ propType prop+  line $ "get" ++ pName ++ " obj = liftIO $ getObjectProperty" ++ tStr+        ++ " obj \"" ++ T.unpack (propName prop) ++ "\"" +++           if tStr `elem` ["Object", "Boxed"]+           then " " ++ show outType -- These require the constructor too.+           else ""++genPropertyConstructor :: String -> Property -> CodeGen ()+genPropertyConstructor pName prop = group $ do+  (constraints, t) <- attrType prop+  tStr <- propTypeStr $ propType prop+  let constraints' =+          case constraints of+            [] -> ""+            _ -> parenthesize (intercalate ", " constraints) ++ " => "+  line $ "construct" ++ pName ++ " :: " ++ constraints'+           ++ t ++ " -> IO ([Char], GValue)"+  line $ "construct" ++ pName ++ " val = constructObjectProperty" ++ tStr+           ++ " \"" ++ T.unpack (propName prop) ++ "\" val"++genObjectProperties :: Name -> Object -> CodeGen ()+genObjectProperties n o = do+  isGO <- apiIsGObject n (APIObject o)+  -- We do not generate bindings for objects not descending from GObject.+  when isGO $ do+    allProps <- fullObjectPropertyList n o >>=+                mapM (\(owner, prop) -> do+                        pi <- infoType owner prop+                        return $ "'(\"" ++ T.unpack (propName prop)+                                   ++ "\", " ++ pi ++ ")")+    genProperties n (objProperties o) allProps++genInterfaceProperties :: Name -> Interface -> CodeGen ()+genInterfaceProperties n iface = do+  allProps <- fullInterfacePropertyList n iface >>=+                mapM (\(owner, prop) -> do+                        pi <- infoType owner prop+                        return $ "'(\"" ++ T.unpack (propName prop)+                                   ++ "\", " ++ pi ++ ")")+  genProperties n (ifProperties iface) allProps++-- If the given accesor is available (indicated by available == True),+-- generate a fully qualified accesor name, otherwise just return+-- "undefined". accessor is "get", "set" or "construct"+accessorOrUndefined :: Bool -> String -> Name -> String -> CodeGen String+accessorOrUndefined available accessor (Name ons on) cName =+    if not available+    then return "undefined"+    else do+      prefix <- qualifyWithSuffix "A." ons+      return $ prefix ++ accessor ++ on ++ cName++-- | The name of the type encoding the information for the property of+-- the object.+infoType :: Name -> Property -> CodeGen String+infoType owner prop = do+  name <- upperNameWithSuffix "A." owner+  let cName = (hyphensToCamelCase . T.unpack . propName) prop+  return $ name ++ cName ++ "PropertyInfo"++genOneProperty :: Name -> Property -> ExcCodeGen ()+genOneProperty owner prop = do+  name <- upperName owner+  let cName = (hyphensToCamelCase . T.unpack . propName) prop+      pName = name ++ cName+      flags = propFlags prop+      writable = PropertyWritable `elem` flags &&+                 (PropertyConstructOnly `notElem` flags)+      readable = PropertyReadable `elem` flags+      constructOnly = PropertyConstructOnly `elem` flags++  -- For properties the meaning of having transfer /= TransferNothing+  -- is not clear (what are the right semantics for GValue setters?),+  -- and the other possibilities are very uncommon, so let us just+  -- assume that TransferNothing is always the case.+  when (propTransfer prop /= TransferNothing) $+       notImplementedError $ "Property " ++ pName+                               ++ " has unsupported transfer type "+                               ++ show (propTransfer prop)++  getter <- accessorOrUndefined readable "get" owner cName+  setter <- accessorOrUndefined writable "set" owner cName+  constructor <- accessorOrUndefined (writable || constructOnly)+                 "construct" owner cName++  unless (readable || writable || constructOnly) $+       notImplementedError $ "Property is not readable, writable, or constructible: "+                               ++ show pName++  group $ do+    line $ "-- VVV Prop \"" ++ T.unpack (propName prop) ++ "\""+    line $ "   -- Type: " ++ show (propType prop)+    line $ "   -- Flags: " ++ show (propFlags prop)++  when readable $ genPropertyGetter owner pName prop+  when writable $ genPropertySetter owner pName prop+  when (writable || constructOnly) $ genPropertyConstructor pName prop++  outType <- if not readable+             then return "()"+             else do+               sOutType <- show <$> haskellType (propType prop)+               return $ if ' ' `elem` sOutType+                        then parenthesize sOutType+                        else sOutType++  -- Polymorphic _label style lens+  group $ do+    inIsGO <- isGObject (propType prop)+    hInType <- show <$> haskellType (propType prop)+    let inConstraint = if writable || constructOnly+                       then if inIsGO+                            then classConstraint hInType+                            else "(~) " ++ if ' ' `elem` hInType+                                           then parenthesize hInType+                                           else hInType+                       else "(~) ()"+        allowedOps = (if writable+                      then ["'AttrSet", "'AttrConstruct"]+                      else [])+                     <> (if constructOnly+                         then ["'AttrConstruct"]+                         else [])+                     <> (if readable+                         then ["'AttrGet"]+                         else [])+    it <- infoType owner prop++    line $ "data " ++ it+    line $ "instance AttrInfo " ++ it ++ " where"+    indent $ do+            line $ "type AttrAllowedOps " ++ it+                     ++ " = '[ " ++ intercalate ", " allowedOps ++ "]"+            line $ "type AttrSetTypeConstraint " ++ it+                     ++ " = " ++ inConstraint+            line $ "type AttrBaseTypeConstraint " ++ it+                     ++ " = " ++ classConstraint name+            line $ "type AttrGetType " ++ it ++ " = " ++ outType+            line $ "type AttrLabel " ++ it ++ " = \""+                     ++ name ++ "::" ++ T.unpack (propName prop) ++ "\""+            line $ "attrGet _ = " ++ getter+            line $ "attrSet _ = " ++ setter+            line $ "attrConstruct _ = " ++ constructor++-- | Generate a placeholder property for those cases in which code+-- generation failed.+genPlaceholderProperty :: Name -> Property -> CodeGen ()+genPlaceholderProperty owner prop = do+  line $ "-- XXX Placeholder"+  it <- infoType owner prop+  line $ "data " ++ it+  line $ "instance AttrInfo " ++ it ++ " where"+  indent $ do+    line $ "type AttrAllowedOps " ++ it ++ " = '[]"+    line $ "type AttrSetTypeConstraint " ++ it ++ " = (~) ()"+    line $ "type AttrBaseTypeConstraint " ++ it ++ " = (~) ()"+    line $ "type AttrGetType " ++ it ++ " = ()"+    line $ "type AttrLabel " ++ it ++ " = \"\""+    line $ "attrGet = undefined"+    line $ "attrSet = undefined"+    line $ "attrConstruct = undefined"++genProperties :: Name -> [Property] -> [String] -> CodeGen ()+genProperties n ownedProps allProps = do+  name <- upperName n++  forM_ ownedProps $ \prop -> do+      handleCGExc (\err -> do+                     line $ "-- XXX Generation of property \""+                              ++ T.unpack (propName prop) ++ "\" of object \""+                              ++ name ++ "\" failed: " ++ describeCGError err+                     genPlaceholderProperty n prop)+                  (genOneProperty n prop)++  group $ line $ "type instance AttributeList " ++ name ++ " = '[ "+            ++ intercalate ", " allProps ++ "]"
+ src/GI/Signal.hs view
@@ -0,0 +1,312 @@+module GI.Signal+    ( genSignal+    , genCallback+    , signalHaskellName+    ) where++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative ((<$>))+#endif+import Control.Monad (forM, forM_, when, unless)++import Data.List (intercalate)+import Data.Typeable (typeOf)+import Data.Bool (bool)+import qualified Data.Text as T++import Text.Show.Pretty (ppShow)++import GI.API+import GI.Callable (hOutType, arrayLengths, wrapMaybe)+import GI.Code+import GI.Conversions+import GI.SymbolNaming+import GI.Transfer (freeContainerType)+import GI.Type+import GI.Util (split, parenthesize, withComment)++-- The prototype of the callback on the Haskell side (what users of+-- the binding will see)+genHaskellCallbackPrototype :: Callable -> String -> [Arg] -> [Arg] ->+                               ExcCodeGen ()+genHaskellCallbackPrototype cb name' hInArgs hOutArgs = do+  group $ do+    line $ "type " ++ name' ++ " ="+    indent $ do+      forM_ hInArgs $ \arg -> do+        ht <- haskellType (argType arg)+        wrapMaybe arg >>= bool+                          (line $ show ht ++ " ->")+                          (line $ show (maybeT ht) ++ " ->")+      ret <- hOutType cb hOutArgs False+      line $ show $ io ret++  -- For optional parameters, in case we want to pass Nothing.+  group $ do+    line $ "no" ++ name' ++ " :: Maybe " ++ name'+    line $ "no" ++ name' ++ " = Nothing"++-- Prototype of the callback on the C side+genCCallbackPrototype :: Callable -> String -> Bool -> CodeGen ()+genCCallbackPrototype cb name' isSignal =+  group $ do+    line $ "type " ++ name' ++ "C ="+    indent $ do+      when isSignal $ line $ withComment "Ptr () ->" "object"+      forM_ (args cb) $ \arg -> do+        ht <- foreignType $ argType arg+        let ht' = if direction arg /= DirectionIn+                  then ptr ht+                  else ht+        line $ show ht' ++ " ->"+      when isSignal $ line $ withComment "Ptr () ->" "user_data"+      ret <- io <$> case returnType cb of+                      TBasicType TVoid -> return $ typeOf ()+                      t -> foreignType t+      line $ show ret++-- Generator for wrappers callable from C+genCallbackWrapperFactory :: String -> CodeGen ()+genCallbackWrapperFactory name' =+  group $ do+    line "foreign import ccall \"wrapper\""+    indent $ line $ "mk" ++ name' ++ " :: "+               ++ name' ++ "C -> IO (FunPtr " ++ name' ++ "C)"++-- Generator of closures+genClosure :: String -> String -> Bool -> CodeGen ()+genClosure callback closure isSignal =+    group $ do+      line $ closure ++ " :: " ++ callback ++ " -> IO Closure"+      line $ closure ++ " cb = newCClosure =<< mk" ++ callback ++ " wrapped"+      indent $+         line $ "where wrapped = " ++ lcFirst callback ++ "Wrapper " +++              if isSignal+              then "cb"+              else "Nothing cb"++-- Wrap a conversion of a nullable object into "Maybe" object, by+-- checking whether the pointer is NULL.+convertNullable :: String -> BaseCodeGen e String -> BaseCodeGen e String+convertNullable aname c = do+  line $ "maybe" ++ ucFirst aname ++ " <-"+  indent $ do+    line $ "if " ++ aname ++ " == nullPtr"+    line   "then return Nothing"+    line   "else do"+    indent $ do+             unpacked <- c+             line $ "return $ Just " ++ unpacked+    return $ "maybe" ++ ucFirst aname++-- Convert a non-zero terminated out array, stored in a variable+-- named "aname", into the corresponding Haskell object.+convertCallbackInCArray :: Callable -> Arg -> Type -> String -> ExcCodeGen String+convertCallbackInCArray callable arg t@(TCArray False (-1) length _) aname =+  if length > -1+  then wrapMaybe arg >>= bool convertAndFree+                         (convertNullable aname convertAndFree)+  else+    -- Not much we can do, we just pass the pointer along, and let+    -- the callback deal with it.+    return aname+  where+    lname = escapeReserved $ argName $ args callable !! length++    convertAndFree :: ExcCodeGen String+    convertAndFree = do+      unpacked <- convert aname $ unpackCArray lname t (transfer arg)+      -- Free the memory associated with the array+      freeContainerType (transfer arg) t aname lname+      return unpacked++-- Remove the warning, this should never be reached.+convertCallbackInCArray _ t _ _ =+    error $ "convertOutCArray : unexpected " ++ show t++-- Prepare an argument for passing into the Haskell side.+prepareArgForCall :: Callable -> Arg -> ExcCodeGen String+prepareArgForCall cb arg = case direction arg of+  DirectionIn -> prepareInArg cb arg+  DirectionInout -> prepareInoutArg arg+  DirectionOut -> error "Unexpected DirectionOut!"++prepareInArg :: Callable -> Arg -> ExcCodeGen String+prepareInArg cb arg = do+  let name = (escapeReserved . argName) arg+  case argType arg of+    t@(TCArray False _ _ _) -> convertCallbackInCArray cb arg t name+    _ -> do+      let c = convert name $ fToH (argType arg) (transfer arg)+      wrapMaybe arg >>= bool c (convertNullable name c)++prepareInoutArg :: Arg -> ExcCodeGen String+prepareInoutArg arg = do+  let name = (escapeReserved . argName) arg+  name' <- genConversion name $ apply $ M "peek"+  convert name' $ fToH (argType arg) (transfer arg)++saveOutArg :: Arg -> ExcCodeGen ()+saveOutArg arg = do+  let name = (escapeReserved . argName) arg+      name' = "out" ++ name+  when (transfer arg /= TransferEverything) $+       notImplementedError $ "Unexpected transfer type for \"" ++ name ++ "\""+  name'' <- convert name' $ hToF (argType arg) TransferEverything+  line $ "poke " ++ name ++ " " ++ name''++-- The wrapper itself, marshalling to and from Haskell. The first+-- argument is possibly a pointer to a FunPtr to free (via+-- freeHaskellFunPtr) once the callback is run once, or Nothing if the+-- FunPtr will be freed by someone else (the function registering the+-- callback for ScopeTypeCall, or a destroy notifier for+-- ScopeTypeNotified).+genCallbackWrapper :: Callable -> String -> [Arg] -> [Arg] -> [Arg] ->+                      Bool -> ExcCodeGen ()+genCallbackWrapper cb name' dataptrs hInArgs hOutArgs isSignal = do+  let cName arg = if arg `elem` dataptrs+                  then "_"+                  else (escapeReserved . argName) arg+      cArgNames = map cName (args cb)++  group $ do+    line $ lcFirst name' ++ "Wrapper ::"+    indent $ do+      unless isSignal $+           line $ "Maybe (Ptr (FunPtr (" ++ name' ++ "C))) ->"+      line $ name' ++ " ->"+      when isSignal $ line "Ptr () ->"+      forM_ (args cb) $ \arg -> do+        ht <- foreignType $ argType arg+        let ht' = if direction arg /= DirectionIn+                  then ptr ht+                  else ht+        line $ show ht' ++ " ->"+      when isSignal $ line "Ptr () ->"+      ret <- io <$> case returnType cb of+                      TBasicType TVoid -> return $ typeOf ()+                      t -> foreignType t+      line $ show ret++    let allArgs = if isSignal+                  then unwords $ ["_cb", "_"] ++ cArgNames ++ ["_"]+                  else unwords $ ["funptrptr", "_cb"] ++ cArgNames+    line $ lcFirst name' ++ "Wrapper " ++ allArgs ++ " = do"+    indent $ do+      hInNames <- forM hInArgs (prepareArgForCall cb)++      let maybeReturn = case returnType cb of+                          TBasicType TVoid -> []+                          _                -> ["result"]+          argName' = escapeReserved . argName+          returnVars = maybeReturn ++ map (("out"++) . argName') hOutArgs+          returnBind = case returnVars of+                         []  -> ""+                         [r] -> r ++ " <- "+                         _   -> parenthesize (intercalate ", " returnVars) ++ " <- "+      line $ returnBind ++ "_cb " ++ concatMap (" " ++) hInNames++      forM_ hOutArgs saveOutArg++      unless isSignal $ line "maybeReleaseFunPtr funptrptr"++      when (returnType cb /= TBasicType TVoid) $+           if returnMayBeNull cb+           then do+             line "maybeM nullPtr result $ \\result' -> do"+             indent $ unwrapped "result'"+           else unwrapped "result"+           where+             unwrapped rname = do+               result' <- convert rname $ hToF (returnType cb) (returnTransfer cb)+               line $ "return " ++ result'++genCallback :: Name -> Callback -> CodeGen ()+genCallback n (Callback cb) = do+  name' <- upperName n+  line $ "-- callback " ++ name'++  let -- user_data pointers, which we generically omit+      dataptrs = map (args cb !!) . filter (/= -1) . map argClosure $ args cb+      hidden = dataptrs ++ arrayLengths cb++      inArgs = filter ((/= DirectionOut) . direction) $ args cb+      hInArgs = filter (not . (`elem` hidden)) inArgs+      outArgs = filter ((/= DirectionIn) . direction) $ args cb+      hOutArgs = filter (not . (`elem` hidden)) outArgs++  if skipReturn cb+  then group $ do+    line $ "-- XXX Skipping callback " ++ name'+    line $ "-- Callbacks skipping return unsupported :\n"+             ++ ppShow n ++ "\n" ++ ppShow cb+  else do+    let closure = lcFirst name' ++ "Closure"++    handleCGExc (\e -> line ("-- XXX Could not generate callback wrapper for "+                             ++ name' +++                             "\n-- Error was : " ++ describeCGError e))+       (genClosure name' closure False >>+        genCCallbackPrototype cb name' False >>+        genCallbackWrapperFactory name' >>+        genHaskellCallbackPrototype cb name' hInArgs hOutArgs >>+        genCallbackWrapper cb name' dataptrs hInArgs hOutArgs False)++-- | Return the name for the signal in Haskell CamelCase conventions.+signalHaskellName :: String -> String+signalHaskellName sn = let (w:ws) = split '-' sn+                       in w ++ concatMap ucFirst ws++genSignal :: Signal -> Name -> ExcCodeGen ()+genSignal (Signal { sigName = sn, sigCallable = cb }) on = do+  on' <- upperName on++  line $ "-- signal " ++ on' ++ "::" ++ T.unpack sn++  let inArgs = filter ((/= DirectionOut) . direction) $ args cb+      hInArgs = filter (not . (`elem` arrayLengths cb)) inArgs+      outArgs = filter ((/= DirectionIn) . direction) $ args cb+      hOutArgs = filter (not . (`elem` arrayLengths cb)) outArgs+      sn' = signalHaskellName (T.unpack sn)+      signalConnectorName = on' ++ ucFirst sn'+      cbType = signalConnectorName ++ "Callback"++  genHaskellCallbackPrototype cb cbType hInArgs hOutArgs++  genCCallbackPrototype cb cbType True++  genCallbackWrapperFactory cbType++  let closure = lcFirst signalConnectorName ++ "Closure"+  genClosure cbType closure True++  genCallbackWrapper cb cbType [] hInArgs hOutArgs True++  -- Wrapper for connecting functions to the signal+  -- We can connect to a signal either before the default handler runs+  -- ("on...") or after the default handler runs (after...). We+  -- provide convenient wrappers for both cases.+  group $ do+    let signatureConstraints = "(GObject a, MonadIO m) =>"+        signatureArgs = "a -> " ++ cbType ++ " -> m SignalHandlerId"+        signature = " :: " ++ signatureConstraints ++ " " ++ signatureArgs+        onName = "on" ++ signalConnectorName+        afterName = "after" ++ signalConnectorName+    line $ onName ++ signature+    line $ onName ++ " obj cb = liftIO $ connect"+             ++ signalConnectorName ++ " obj cb SignalConnectBefore"+    line $ afterName ++ signature+    line $ afterName ++ " obj cb = connect"+             ++ signalConnectorName ++ " obj cb SignalConnectAfter"++  group $ do+    let fullName = "connect" ++ signalConnectorName+        signatureConstraints = "(GObject a, MonadIO m) =>"+        signatureArgs = "a -> " ++ cbType+                        ++ " -> SignalConnectMode -> m SignalHandlerId"+    line $ fullName ++ " :: " ++ signatureConstraints+    line $ replicate (4 + length fullName) ' ' ++ signatureArgs+    line $ fullName ++ " obj cb after = liftIO $ do"+    indent $ do+        line $ "cb' <- mk" ++ cbType ++ " (" ++ lcFirst cbType ++ "Wrapper cb)"+        line $ "connectSignalFunPtr obj \"" ++ T.unpack sn ++ "\" cb' after"
+ src/GI/Struct.hs view
@@ -0,0 +1,103 @@+module GI.Struct ( genStructOrUnionFields+                 , extractCallbacksInStruct+                 , fixAPIStructs+                 , ignoreStruct)+    where++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative ((<$>))+#endif+import Control.Monad (forM_, unless, when)++import Data.List (isSuffixOf)+import Data.Maybe (mapMaybe, isJust)+import Data.Text (unpack)++import GI.API+import GI.Conversions+import GI.Code+import GI.SymbolNaming+import GI.Type+import GI.Util++-- | Whether (not) to generate bindings for the given struct.+ignoreStruct :: Name -> Struct -> Bool+ignoreStruct (Name _ name) s = isJust (gtypeStructFor s) ||+                               "Private" `isSuffixOf` name++-- | Canonical name for the type of a callback type embedded in a+-- struct field.+fieldCallbackType :: String -> Field -> String+fieldCallbackType structName field = structName+                                     ++ (underscoresToCamelCase . unpack .+                                         fieldName) field+                                     ++ "FieldCallback"++-- | Fix the interface names of callback fields in the struct to+-- correspond to the ones that we are going to generate.+fixCallbackStructFields :: Name -> Struct -> Struct+fixCallbackStructFields (Name ns structName) s = s {structFields = fixedFields}+    where fixedFields :: [Field]+          fixedFields = map fixField (structFields s)++          fixField :: Field -> Field+          fixField field =+              case fieldCallback field of+                Nothing -> field+                Just _ -> let n' = fieldCallbackType structName field+                          in field {fieldType = TInterface ns n'}++-- | Fix the interface names of callback fields in an APIStruct to+-- correspond to the ones that we are going to generate. If something+-- other than an APIStruct is passed in we don't touch it.+fixAPIStructs :: (Name, API) -> (Name, API)+fixAPIStructs (n, APIStruct s) = (n, APIStruct $ fixCallbackStructFields n s)+fixAPIStructs api = api++-- | Extract the callback types embedded in the fields of structs, and+-- at the same time fix the type of the corresponding fields. Returns+-- the list of APIs associated to this struct, not including the+-- struct itself.+extractCallbacksInStruct :: (Name, API) -> [(Name, API)]+extractCallbacksInStruct (n@(Name ns structName), APIStruct s)+    | ignoreStruct n s = []+    | otherwise =+        mapMaybe callbackInField (structFields s)+            where callbackInField :: Field -> Maybe (Name, API)+                  callbackInField field = do+                    callback <- fieldCallback field+                    let n' = fieldCallbackType structName field+                    return (Name ns n', APICallback callback)+extractCallbacksInStruct _ = []++buildFieldGetter :: Name -> Field -> ExcCodeGen ()+buildFieldGetter n@(Name ns _) field = do+  name' <- upperName n++  hType <- show <$> haskellType (fieldType field)+  fType <- show <$> foreignType (fieldType field)+  unless ("Private" `isSuffixOf` hType) $ do+     fName <- upperName $ Name ns (unpack . fieldName $ field)+     let getter = lcFirst name' ++ "Read" ++ fName+     line $ getter ++ " :: " ++ name' ++ " -> IO " +++                 if ' ' `elem` hType+                 then parenthesize hType+                 else hType+     line $ getter ++ " s = withManagedPtr s $ \\ptr -> do"+     indent $ do+       line $ "val <- peek (ptr `plusPtr` " ++ show (fieldOffset field)+            ++ ") :: IO " ++ if ' ' `elem` fType+                            then parenthesize fType+                            else fType+       result <- convert "val" $ fToH (fieldType field) TransferNothing+       line $ "return " ++ result++genStructOrUnionFields :: Name -> [Field] -> CodeGen ()+genStructOrUnionFields n fields = do+  name' <- upperName n++  forM_ fields $ \field -> when (fieldVisible field) $ group $+      handleCGExc (\e -> line ("-- XXX Skipped getter for \"" ++ name' +++                               ":" ++ unpack (fieldName field) ++ "\" :: " +++                               describeCGError e))+                  (buildFieldGetter n field)
+ src/GI/SymbolNaming.hs view
@@ -0,0 +1,129 @@+module GI.SymbolNaming+    ( qualify+    , qualifyWithSuffix+    , ucFirst+    , lcFirst+    , lowerName+    , upperName+    , upperNameWithSuffix+    , noName+    , escapeReserved+    , classConstraint+    , hyphensToCamelCase+    , underscoresToCamelCase+    ) where++import Data.Char (toLower, toUpper)+#if !MIN_VERSION_base(4,8,0)+import Data.Monoid (Monoid, (<>))+#else+import Data.Monoid ((<>))+#endif+import Data.Text (Text)+import qualified Data.Text as T+import Data.String (IsString)++import GI.API+import GI.Code+import GI.Config (Config(modName))+import GI.Util (split)++classConstraint :: (Monoid a, IsString a) => a -> a+classConstraint n = n <> "K"++ucFirst (x:xs) = toUpper x : xs+ucFirst "" = error "ucFirst: empty string"++lcFirst (x:xs) = toLower x : xs+lcFirst "" = error "lcFirst: empty string"++lowerName :: Name -> CodeGen String+lowerName (Name _ s) = return $ concat . rename $ split '_' s+    where+      rename [w] = [lcFirst w]+      rename (w:ws) = lcFirst w : map ucFirst' ws+      rename [] = error "rename: empty list"++      ucFirst' "" = "_"+      ucFirst' x = ucFirst x++upperNameWithSuffix :: String -> Name -> CodeGen String+upperNameWithSuffix suffix (Name ns s) = do+          prefix <- qualifyWithSuffix suffix ns+          return $ prefix ++ uppered+    where uppered = concatMap ucFirst' $ split '_' $ sanitize s+          -- Move leading underscores to the end (for example in+          -- GObject::_Value_Data_Union -> GObject::Value_Data_Union_)+          sanitize ('_':xs) = sanitize xs ++ "_"+          sanitize xs = xs++          ucFirst' "" = "_"+          ucFirst' x = ucFirst x++upperName :: Name -> CodeGen String+upperName = upperNameWithSuffix "."++-- | Return a qualified prefix for the given namespace. In case the+-- namespace corresponds to the current module the empty string is+-- returned, otherwise the namespace ++ suffix is returned. Suffix is+-- typically just ".", see `qualify` below.+qualifyWithSuffix :: String -> String -> CodeGen String+qualifyWithSuffix suffix ns = do+     cfg <- config+     if modName cfg == Just ns then+         return ""+     else do+       loadDependency ns -- Make sure that the given namespace is listed+                         -- as a dependency of this module.+       return $ ucFirst ns ++ suffix++-- | Return the qualified namespace (ns ++ "." or "", depending on+-- whether ns is the current namespace).+qualify :: String -> CodeGen String+qualify = qualifyWithSuffix "."++-- | Save a bit of typing for optional arguments in the case that we+-- want to pass Nothing.+noName :: String -> CodeGen ()+noName name' = group $ do+                 line $ "no" ++ name' ++ " :: Maybe " ++ name'+                 line $ "no" ++ name' ++ " = Nothing"++-- | For a string of the form "one-sample-string" return "OneSampleString"+hyphensToCamelCase :: String -> String+hyphensToCamelCase str = concatMap ucFirst $ split '-' str++-- | Similarly, turn a name separated_by_underscores into CamelCase.+underscoresToCamelCase :: String -> String+underscoresToCamelCase str = concatMap ucFirst $ split '_' str++escapeReserved :: Text -> String+escapeReserved "type" = "type_"+escapeReserved "in" = "in_"+escapeReserved "data" = "data_"+escapeReserved "instance" = "instance_"+escapeReserved "where" = "where_"+escapeReserved "module" = "module_"+-- Reserved because we generate code that uses these names.+escapeReserved "result" = "result_"+escapeReserved "return" = "return_"+escapeReserved "show" = "show_"+escapeReserved "fromEnum" = "fromEnum_"+escapeReserved "toEnum" = "toEnum_"+escapeReserved "undefined" = "undefined_"+escapeReserved "error" = "error_"+escapeReserved "map" = "map_"+escapeReserved "length" = "length_"+escapeReserved "mapM" = "mapM__"+escapeReserved "mapM_" = "mapM___"+escapeReserved "fromIntegral" = "fromIntegral_"+escapeReserved "realToFrac" = "realToFrac_"+escapeReserved "peek" = "peek_"+escapeReserved "poke" = "poke_"+escapeReserved "sizeOf" = "sizeOf_"+escapeReserved "when" = "when_"+escapeReserved "default" = "default_"+escapeReserved s+    | "set_" `T.isPrefixOf` s = T.unpack s <> "_"+    | "get_" `T.isPrefixOf` s = T.unpack s <> "_"+    | otherwise = T.unpack s
+ src/GI/Transfer.hs view
@@ -0,0 +1,247 @@+-- Routines dealing with memory management in marshalling functions.++module GI.Transfer+    ( freeInArg+    , freeInArgOnError+    , freeContainerType+    ) where++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative ((<$>), (<*>))+#endif++import Control.Monad (when)+import Data.Maybe (isJust)++import GI.API+import GI.Code+import GI.Conversions+import GI.GObject+import GI.SymbolNaming (ucFirst)+import GI.Type+import GI.Util++-- Basic primitives for freeing the given types. Types that point to+-- Haskell objects with memory managed by the GC should not be freed+-- here. For containers this is only for freeing the container itself,+-- freeing the elements is done separately.+basicFreeFn :: Type -> Maybe String+basicFreeFn (TBasicType TUTF8) = Just "freeMem"+basicFreeFn (TBasicType TFileName) = Just "freeMem"+basicFreeFn (TBasicType _) = Nothing+basicFreeFn (TInterface _ _) = Nothing+basicFreeFn (TCArray False (-1) (-1) _) = Nothing -- Just passing it along+basicFreeFn (TCArray{}) = Just "freeMem"+basicFreeFn (TGArray _) = Just "unrefGArray"+basicFreeFn (TPtrArray _) = Just "unrefPtrArray"+basicFreeFn (TByteArray) = Just "unrefGByteArray"+basicFreeFn (TGList _) = Just "g_list_free"+basicFreeFn (TGSList _) = Just "g_slist_free"+basicFreeFn (TGHash _ _) = Just "unrefGHashTable"+basicFreeFn (TError) = Nothing+basicFreeFn (TVariant) = Nothing+basicFreeFn (TParamSpec) = Nothing++-- Basic free primitives in the case that an error occured. This is+-- run in the exception handler, so any type which we ref/allocate+-- with the expectation that the called function will consume it (on+-- TransferEverything) should be freed here.+basicFreeFnOnError :: Type -> Transfer -> CodeGen (Maybe String)+basicFreeFnOnError (TBasicType TUTF8) _ = return $ Just "freeMem"+basicFreeFnOnError (TBasicType TFileName) _ = return $ Just "freeMem"+basicFreeFnOnError (TBasicType _) _ = return Nothing+basicFreeFnOnError TVariant transfer =+    return $ if transfer == TransferEverything+             then Just "unrefGVariant"+             else Nothing+basicFreeFnOnError TParamSpec transfer =+    return $ if transfer == TransferEverything+             then Just "unrefGParamSpec"+             else Nothing+basicFreeFnOnError t@(TInterface _ _) transfer = do+  api <- findAPI t+  case api of+    Just (APIObject _) -> if transfer == TransferEverything+                          then do+                            isGO <- isGObject t+                            if isGO+                            then return $ Just "unrefObject"+                            else do+                              line "-- XXX Transfer a non-GObject object"+                              return Nothing+                          else return Nothing+    Just (APIInterface _) -> if transfer == TransferEverything+                             then do+                               isGO <- isGObject t+                               if isGO+                               then return $ Just "unrefObject"+                               else do+                                 line "-- XXX Transfer a non-GObject object"+                                 return Nothing+                             else return Nothing+    Just (APIUnion u) -> if transfer == TransferEverything+                         then if unionIsBoxed u+                              then return $ Just "freeBoxed"+                              else do+                                line "-- XXX Transfer a non-boxed union"+                                return Nothing+                         else return Nothing+    Just (APIStruct s) -> if transfer == TransferEverything+                          then if structIsBoxed s+                               then return $ Just "freeBoxed"+                               else do+                                 line "-- XXX Transfer a non-boxed struct"+                                 return Nothing+                          else return Nothing+    _ -> return Nothing+-- Arrays without length info are just passed along, we do not need to+-- free them.+basicFreeFnOnError (TCArray False (-1) (-1) _) _ = return Nothing+basicFreeFnOnError (TCArray{}) _ = return $ Just "freeMem"+basicFreeFnOnError (TGArray _) _ = return $ Just "unrefGArray"+basicFreeFnOnError (TPtrArray _) _ = return $ Just "unrefPtrArray"+basicFreeFnOnError (TByteArray) _ = return $ Just "unrefGByteArray"+basicFreeFnOnError (TGList _) _ = return $ Just "g_list_free"+basicFreeFnOnError (TGSList _) _ = return $ Just "g_slist_free"+basicFreeFnOnError (TGHash _ _) _ = return $ Just "unrefGHashTable"+basicFreeFnOnError (TError) _ = return Nothing++-- Free just the container, but not the elements.+freeContainer :: Type -> String -> CodeGen [String]+freeContainer t label =+    case basicFreeFn t of+      Nothing -> return []+      Just fn -> return [fn ++ " " ++ label]++-- Free one element using the given free function.+freeElem :: Type -> String -> String -> ExcCodeGen String+freeElem t label free =+    case elementTypeAndMap t undefined of+      Nothing -> return free+      Just (TCArray False _ _ _, _) ->+          badIntroError $ "Element type in container \"" ++ label +++                            "\" is an array of unknown length."+      Just (innerType, mapFn) -> do+        let elemFree = "freeElemOf" ++ ucFirst label+        fullyFree innerType (prime label) >>= \case+                  Nothing -> return $ free ++ " e"+                  Just elemInnerFree -> do+                     line $ "let " ++ elemFree ++ " e = " ++ mapFn ++ " "+                              ++ elemInnerFree ++ " e >> " ++ free ++ " e"+                     return elemFree++-- Construct a function to free the memory associated with a type, and+-- recursively free any elements of this type in case that it is a+-- container.+fullyFree :: Type -> String -> ExcCodeGen (Maybe String)+fullyFree t label = case basicFreeFn t of+                      Nothing -> return Nothing+                      Just free -> Just <$> freeElem t label free++-- Like fullyFree, but free the toplevel element using basicFreeFnOnError.+fullyFreeOnError :: Type -> String -> Transfer -> ExcCodeGen (Maybe String)+fullyFreeOnError t label transfer =+    basicFreeFnOnError t transfer >>= \case+        Nothing -> return Nothing+        Just free -> Just <$> freeElem t label free++-- Free the elements in a container type.+freeElements :: Type -> String -> String -> ExcCodeGen [String]+freeElements t label len =+   case elementTypeAndMap t len of+     Nothing -> return []+     Just (inner, mapFn) ->+         fullyFree inner label >>= \case+                   Nothing -> return []+                   Just innerFree ->+                       return [mapFn ++ " " ++ innerFree ++ " " ++ label]++-- | Free a container and/or the contained elements, depending on the+-- transfer mode.+freeContainerType :: Transfer -> Type -> String -> String -> ExcCodeGen ()+freeContainerType transfer (TGHash _ _) label _ = freeGHashTable transfer label+freeContainerType transfer t label len = do+      when (transfer == TransferEverything) $+           mapM_ line =<< freeElements t label len+      when (transfer /= TransferNothing) $+           mapM_ line =<< freeContainer t label++freeGHashTable :: Transfer -> String -> ExcCodeGen ()+freeGHashTable TransferNothing _ = return ()+freeGHashTable TransferContainer label =+    notImplementedError $ "Hash table argument with transfer = Container? "+                        ++ label+-- Hash tables support setting a free function for keys and elements,+-- we assume that these are always properly set. The worst that can+-- happen this way is a memory leak, as opposed to a double free if we+-- try do free anything here.+freeGHashTable TransferEverything label =+    line $ "unrefGHashTable " ++ label++-- Free the elements of a container type in the case an error ocurred,+-- in particular args that should have been transferred did not get+-- transfered.+freeElementsOnError :: Transfer -> Type -> String -> String ->+                       ExcCodeGen [String]+freeElementsOnError transfer t label len =+    case elementTypeAndMap t len of+      Nothing -> return []+      Just (inner, mapFn) ->+         fullyFreeOnError inner label transfer >>= \case+                   Nothing -> return []+                   Just innerFree ->+                       return [mapFn ++ " " ++ innerFree ++ " " ++ label]++freeIn :: Transfer -> Type -> String -> String -> ExcCodeGen [String]+freeIn transfer (TGHash _ _) label _ =+    freeInGHashTable transfer label+freeIn transfer t label len =+    case transfer of+      TransferNothing -> (++) <$> freeElements t label len <*> freeContainer t label+      TransferContainer -> freeElements t label len+      TransferEverything -> return []++freeInOnError :: Transfer -> Type -> String -> String -> ExcCodeGen [String]+freeInOnError transfer (TGHash _ _) label _ =+    freeInGHashTable transfer label+freeInOnError transfer t label len =+    (++) <$> freeElementsOnError transfer t label len+             <*> freeContainer t label++-- See freeGHashTable above.+freeInGHashTable :: Transfer -> String -> ExcCodeGen [String]+freeInGHashTable TransferEverything _ = return []+freeInGHashTable TransferContainer label =+    notImplementedError $ "Hash table argument with TransferContainer? "+                        ++ label+freeInGHashTable TransferNothing label = return ["unrefGHashTable " ++ label]++freeOut :: String -> CodeGen [String]+freeOut label = return ["freeMem " ++ label]++-- | Given an input argument to a C callable, and its label in the code,+-- return the list of actions relevant to freeing the memory allocated+-- for the argument (if appropriate, depending on the ownership+-- transfer semantics of the callable).+freeInArg :: Arg -> String -> String -> ExcCodeGen [String]+freeInArg arg label len = do+  weAlloc <- isJust <$> requiresAlloc (argType arg)+  -- Arguments that we alloc ourselves do not need to be freed, they+  -- will always be soaked up by the wrapPtr constructor, or they will+  -- be DirectionIn.+  if not weAlloc+  then case direction arg of+         DirectionIn -> freeIn (transfer arg) (argType arg) label len+         DirectionOut -> freeOut label+         DirectionInout -> freeOut label+  else return []++-- | Same thing as freeInArg, but called in case the call to C didn't+-- succeed. We thus free everything we allocated in preparation for+-- the call, including args that would have been transferred to C.+freeInArgOnError :: Arg -> String -> String -> ExcCodeGen [String]+freeInArgOnError arg label len =+    case direction arg of+      DirectionIn -> freeInOnError (transfer arg) (argType arg) label len+      DirectionOut -> freeOut label+      DirectionInout -> freeOut label
+ src/GI/Type.hs view
@@ -0,0 +1,67 @@++module GI.Type+    ( BasicType(..)+    , Type(..)+    , io+    , ptr+    , con+    , maybeT+    ) where++import Data.Typeable+import qualified Data.Text as T+import Data.Text (Text)++-- This enum mirrors the definition in gitypes.h.+data BasicType+     = TVoid+     | TBoolean+     | TInt8+     | TUInt8+     | TInt16+     | TUInt16+     | TInt32+     | TUInt32+     | TInt64+     | TUInt64+     | TFloat+     | TDouble+     | TUniChar+     | TGType+     | TUTF8+     | TFileName+    deriving (Eq, Enum, Show, Ord)++-- This type represents the types found in GObject Introspection+-- interfaces: the types of constants, arguments, etc.+data Type+    = TBasicType BasicType+    -- Zero terminated, Array Fixed Size, Array Length, Element Type+    | TCArray Bool Int Int Type+    | TGArray Type+    | TPtrArray Type+    | TByteArray+    | TInterface String String+    | TGList Type+    | TGSList Type+    | TGHash Type Type+    | TError+    | TVariant+    | TParamSpec+    deriving (Eq, Show, Ord)++con :: Text -> [TypeRep] -> TypeRep+con "[]" xs = mkTyConApp listCon xs+              where listCon = typeRepTyCon (typeOf [True])+con "(,)" xs = mkTyConApp tupleCon xs+               where tupleCon = typeRepTyCon (typeOf (True, True))+con s xs = mkTyConApp (mkTyCon3 "GI" "GI" (T.unpack s)) xs++io :: TypeRep -> TypeRep+io t = "IO" `con` [t]++ptr :: TypeRep -> TypeRep+ptr t = "Ptr" `con` [t]++maybeT :: TypeRep -> TypeRep+maybeT t = "Maybe" `con` [t]
+ src/GI/Util.hs view
@@ -0,0 +1,60 @@+module GI.Util+  ( maybeWithCString+  , getList+  , toFlags+  , split++  , prime+  , unprime+  , parenthesize++  , padTo+  , withComment+  ) where++import Foreign+import Foreign.C++import Data.List (unfoldr)++padTo n s = s ++ replicate (n - length s) ' '+withComment a b = padTo 40 a ++ "-- " ++ b++maybeWithCString :: Maybe String -> (CString -> IO a) -> IO a+maybeWithCString = maybe ($ nullPtr) withCString++getList :: (a -> IO CInt) -> (a -> CInt -> IO b) -> a -> IO [b]+getList getN getOne x = do+    n <- getN x+    mapM (getOne x) [0..n - 1]++toFlags :: Enum a => CInt -> [a]+toFlags n = loop n (sizeOf n * 8 - 1) -- Number of bits in the argument+    where loop _ (-1) = []+          loop n e =+              let rest = loop n (e - 1)+               in if testBit n e then toEnum (2 ^ e) : rest else rest++-- Splits a string separated by the given separator into a list of+-- constituents. For example: split '.' "A.BC.D" = ["A", "BC", "D"]+split :: Char -> String -> [String]+split sep = unfoldr span'+    where span' :: String -> Maybe (String, String)+          span' [] = Nothing+          span' s@(x:xs)+              | x == sep  = Just $ span (/= sep) xs+              | otherwise = Just $ span (/= sep) s++prime :: String -> String+prime = (++ "'")++-- Remove the prime at the end of the given string+unprime :: String -> String+unprime "" = error "Empty variable to unprime!"+unprime primed =+    case last primed of+      '\'' -> init primed+      _ -> error $ primed ++ " is not primed!"++parenthesize :: String -> String+parenthesize s = "(" ++ s ++ ")"
+ src/c/enumStorage.c view
@@ -0,0 +1,122 @@+/*+  Compute the number of bytes required for storage of a given enum,+  assuming that the current compiler gives the same result as the+  compiler used for compiling the library being introspected.++  Adapted from girepository/giroffsets.c, in the gobject-introspection+   distribution. Original copyright below.+*/++/* -*- mode: C; c-file-style: "gnu"; indent-tabs-mode: nil; -*-+ * GObject introspection: Compute structure offsets+ *+ * Copyright (C) 2008 Red Hat, Inc.+ *+ * 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 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., 59 Temple Place - Suite 330,+ * Boston, MA 02111-1307, USA.+ */++/* The C standard specifies that an enumeration can be any char or any signed+ * or unsigned integer type capable of representing all the values of the+ * enumeration. We use test enumerations to figure out what choices the+ * compiler makes. (Ignoring > 32 bit enumerations)+ */++#include <glib.h>++typedef enum {+  ENUM_1 = 1 /* compiler could use int8, uint8, int16, uint16, int32, uint32 */+} Enum1;++typedef enum {+  ENUM_2 = 128 /* compiler could use uint8, int16, uint16, int32, uint32 */+} Enum2;++typedef enum {+  ENUM_3 = 257 /* compiler could use int16, uint16, int32, uint32 */+} Enum3;++typedef enum {+  ENUM_4 = G_MAXSHORT + 1 /* compiler could use uint16, int32, uint32 */+} Enum4;++typedef enum {+  ENUM_5 = G_MAXUSHORT + 1 /* compiler could use int32, uint32 */+} Enum5;++typedef enum {+  ENUM_6 = ((guint)G_MAXINT) + 1 /* compiler could use uint32 */+} Enum6;++typedef enum {+  ENUM_7 = -1 /* compiler could use int8, int16, int32 */+} Enum7;++typedef enum {+  ENUM_8 = -129 /* compiler could use int16, int32 */+} Enum8;++typedef enum {+  ENUM_9 = G_MINSHORT - 1 /* compiler could use int32 */+} Enum9;++int+_gi_get_enum_storage_bytes (gint64 min_value, gint64 max_value)+{+  int width;++  if (min_value < 0)+    {+      if (min_value > -128 && max_value <= 127)+	width = sizeof(Enum7);+      else if (min_value >= G_MINSHORT && max_value <= G_MAXSHORT)+	width = sizeof(Enum8);+      else+	width = sizeof(Enum9);+    }+  else+    {+      if (max_value <= 127)+	{+	  width = sizeof (Enum1);+	}+      else if (max_value <= 255)+	{+	  width = sizeof (Enum2);+	}+      else if (max_value <= G_MAXSHORT)+	{+	  width = sizeof (Enum3);+	}+      else if (max_value <= G_MAXUSHORT)+	{+	  width = sizeof (Enum4);+	}+      else if (max_value <= G_MAXINT)+	{+	  width = sizeof (Enum5);+	}+      else+	{+	  width = sizeof (Enum6);+	}+    }++  if (width == 1 || width == 2 || width == 4 || width == 8) {+    return width;+  } else {+    g_error("Unexpected enum width %d", width);+  }+}
+ src/haskell-gi.hs view
@@ -0,0 +1,244 @@+module Main where++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative ((<$>))+import Data.Traversable (traverse)+#endif+import Control.Monad (forM_, when, (>=>))+import Control.Exception (handle)++import Data.Bool (bool)+import Data.List (intercalate)+import Data.Text (pack, unpack, Text)++import System.Directory (createDirectoryIfMissing, doesFileExist)+import System.FilePath (splitPath, joinPath)+import System.Console.GetOpt+import System.Exit+import System.IO (hPutStr, hPutStrLn, stderr)+import System.Environment (getArgs)++import qualified Data.Map as M+import qualified Data.Text as T+import qualified Data.Text.IO as TIO+import qualified Data.Set as S++import Data.GI.Base.GError+import Text.Show.Pretty (ppShow)++import GI.API (loadGIRInfo, loadRawGIRInfo, GIRInfo(girAPIs, girNSName), Name, API)+import GI.Cabal (cabalConfig, setupHs, genCabalProject)+import GI.Code (codeToString, genCode, evalCodeGen)+import GI.Config (Config(..))+import GI.CodeGen (genModule)+import GI.Attributes (genAttributes, genAllAttributes)+import GI.OverloadedSignals (genSignalInstances, genOverloadedSignalConnectors)+import GI.Overrides (Overrides, parseOverridesFile, nsChooseVersion, filterAPIsAndDeps)+import GI.ProjectInfo (licenseText)+import GI.SymbolNaming (ucFirst)++data Mode = GenerateCode | Dump | Attributes | Signals | Help++data Options = Options {+  optMode :: Mode,+  optOutput :: Maybe String,+  optOverridesFiles :: [String],+  optSearchPaths :: [String],+  optVerbose :: Bool,+  optCabal :: Bool}++defaultOptions = Options {+  optMode = GenerateCode,+  optOutput = Just "GI",+  optOverridesFiles = [],+  optSearchPaths = [],+  optVerbose = False,+  optCabal = True}++parseKeyValue s =+  let (a, '=':b) = break (=='=') s+   in (a, b)++optDescrs :: [OptDescr (Options -> Options)]+optDescrs = [+  Option "h" ["help"] (NoArg $ \opt -> opt { optMode = Help })+    "\tprint this gentle help text",+  Option "a" ["attributes"] (NoArg $ \opt -> opt {optMode = Attributes})+    "generate generic attribute accesors",+  Option "c" ["connectors"] (NoArg $ \opt -> opt {optMode = Signals})+    "generate generic signal connectors",+  Option "d" ["dump"] (NoArg $ \opt -> opt { optMode = Dump })+    "\tdump internal representation",+  Option "n" ["no-cabal"] (NoArg $ \opt -> opt {optCabal = False})+    "\tdo not generate .cabal file",+  Option "o" ["overrides"] (ReqArg+                           (\arg opt -> opt {optOverridesFiles =+                                                 arg : optOverridesFiles opt})+                          "OVERRIDES")+    "specify a file with overrides info",+  Option "O" ["output"] (ReqArg+                         (\arg opt -> opt {optOutput = Just arg}) "DIR")+    "\tset the output directory",+  Option "s" ["search"] (ReqArg+    (\arg opt -> opt { optSearchPaths = arg : optSearchPaths opt }) "PATH")+    "\tprepend a directory to the typelib search path",+  Option "v" ["verbose"] (NoArg $ \opt -> opt { optVerbose = True })+    "\tprint extra info while processing"]++showHelp = concatMap optAsLine optDescrs+  where optAsLine (Option flag (long:_) _ desc) =+          "  -" ++ flag ++ "|--" ++ long ++ "\t" ++ desc ++ "\n"+        optAsLine _ = error "showHelp"++printGError = handle (gerrorMessage >=> putStrLn . unpack)++outputPath :: Options -> IO (String, String) -- modPrefix, dirPrefix+outputPath options =+    case optOutput options of+      Nothing -> return ("", ".")+      Just dir -> do+        createDirectoryIfMissing True dir+        let prefix = intercalate "." (splitPath dir) ++ "."+        return (prefix, dir)++-- | Load the given API and dependencies, filtering them in the process.+loadFilteredAPI :: Bool -> Overrides -> [FilePath] -> Text+                -> IO (M.Map Name API, M.Map Name API)+loadFilteredAPI verbose ovs extraPaths name = do+  (gir, girDeps) <- loadGIRInfo verbose name Nothing extraPaths+  return $ filterAPIsAndDeps ovs gir girDeps++-- | Load a dependency without further postprocessing.+loadRawAPIs :: Bool -> [FilePath] -> Text -> IO [(Name, API)]+loadRawAPIs verbose extraPaths name = do+  gir <- loadRawGIRInfo verbose name Nothing extraPaths+  return (girAPIs gir)++-- Generate all generic accessor functions ("_label", for example).+genGenericAttrs :: Options -> Overrides -> [Text] -> [FilePath] -> IO ()+genGenericAttrs options ovs modules extraPaths = do+  apis <- mapM (loadRawAPIs (optVerbose options) extraPaths) modules+  let allAPIs = M.unions (map M.fromList apis)+      cfg = Config {modName = Nothing,+                    verbose = optVerbose options,+                    overrides = ovs}+  (modPrefix, dirPrefix) <- outputPath options+  putStrLn $ "\t* Generating " ++ modPrefix ++ "Properties"+  (_, code) <- genCode cfg allAPIs (genAllAttributes (M.toList allAPIs) modPrefix)+  writeFile (joinPath [dirPrefix, "Properties.hs"]) $ codeToString code++-- Generate generic signal connectors ("Clicked", "Activate", ...)+genGenericConnectors :: Options -> Overrides -> [Text] -> [FilePath] -> IO ()+genGenericConnectors options ovs modules extraPaths = do+  apis <- mapM (loadRawAPIs (optVerbose options) extraPaths) modules+  let allAPIs = M.unions (map M.fromList apis)+      cfg = Config {modName = Nothing,+                    verbose = optVerbose options,+                    overrides = ovs}+  (modPrefix, dirPrefix) <- outputPath options+  putStrLn $ "\t* Generating " ++ modPrefix ++ "Signals"+  (_, code) <- genCode cfg allAPIs (genOverloadedSignalConnectors (M.toList allAPIs) modPrefix)+  writeFile (joinPath [dirPrefix, "Signals.hs"]) $ codeToString code++-- Generate the code for the given module, and return the dependencies+-- for this module.+processMod :: Options -> Overrides -> [FilePath] -> String -> IO ()+processMod options ovs extraPaths name = do+  (gir, girDeps) <- loadGIRInfo (optVerbose options) (T.pack name) Nothing extraPaths+  let (apis, deps) = filterAPIsAndDeps ovs gir girDeps+      allAPIs = M.union apis deps++  let cfg = Config {modName = Just name,+                    verbose = optVerbose options,+                    overrides = ovs}+      nm = ucFirst name++  (modPrefix, dirPrefix) <- outputPath options++  putStrLn $ "\t* Generating " ++ modPrefix ++ nm+  (modDeps, code) <- genCode cfg allAPIs (genModule name (M.toList apis) modPrefix)+  writeFile (joinPath [dirPrefix, nm ++ ".hs"]) $+             codeToString code++  putStrLn $ "\t\t+ " ++ modPrefix ++ nm ++ "Attributes"+  (attrDeps, attrCode) <- genCode cfg allAPIs (genAttributes name (M.toList apis) modPrefix)+  writeFile (joinPath [dirPrefix, nm ++ "Attributes.hs"]) $+            codeToString attrCode++  putStrLn $ "\t\t+ " ++ modPrefix ++ nm ++ "Signals"+  (sigDeps, signalCode) <- genCode cfg allAPIs (genSignalInstances name (M.toList apis) modPrefix)+  writeFile (joinPath [dirPrefix, nm ++ "Signals.hs"]) $+            codeToString signalCode++  when (optCabal options) $ do+    let cabal = nm ++ ".cabal"+    fname <- doesFileExist cabal >>=+             bool (return cabal)+                  (putStrLn (cabal ++ " exists, writing "+                             ++ cabal ++ ".new instead") >>+                   return (cabal ++ ".new"))+    putStrLn $ "\t\t+ " ++ fname+    let usedDeps = S.delete name -- The module is not a dep of itself+                   $ S.unions [modDeps, attrDeps, sigDeps]+        -- We only list as dependencies in the cabal file the+        -- dependencies that we use, disregarding what the .gir file says.+        actualDeps = filter ((`S.member` usedDeps) . T.unpack . girNSName) girDeps+    (err, cabalCode) <- evalCodeGen cfg allAPIs (genCabalProject gir actualDeps modPrefix)+    case err of+      Nothing -> do+               writeFile fname (codeToString cabalCode)+               putStrLn "\t\t+ cabal.config"+               writeFile "cabal.config" (T.unpack cabalConfig)+               putStrLn "\t\t+ Setup.hs"+               writeFile "Setup.hs" (T.unpack setupHs)+               putStrLn "\t\t+ LICENSE"+               writeFile "LICENSE" (licenseText)+      Just msg -> putStrLn $ "ERROR: could not generate " ++ fname+                  ++ "\nError was: " ++ msg++dump :: Options -> Overrides -> String -> IO ()+dump options ovs name = do+  (doc, _) <- loadGIRInfo (optVerbose options) (pack name) (pack <$> M.lookup name (nsChooseVersion ovs)) (optSearchPaths options)+  mapM_ (putStrLn . ppShow) (girAPIs doc)++process :: Options -> [String] -> IO ()+process options names = do+  let extraPaths = optSearchPaths options+  configs <- traverse TIO.readFile (optOverridesFiles options)+  case parseOverridesFile (concatMap T.lines configs) of+    Left errorMsg -> do+      hPutStr stderr "Error when parsing the config file(s):\n"+      hPutStr stderr (T.unpack errorMsg)+      exitFailure+    Right ovs ->+      case optMode options of+        GenerateCode -> forM_ names (processMod options ovs extraPaths)+        Attributes -> genGenericAttrs options ovs (map T.pack names) extraPaths+        Signals -> genGenericConnectors options ovs (map T.pack names) extraPaths+        Dump -> forM_ names (dump options ovs)+        Help -> putStr showHelp++foreign import ccall "g_type.h g_type_init"+    g_type_init :: IO ()++main :: IO ()+main = printGError $ do+    g_type_init -- Initialize GLib's type system.+    args <- getArgs+    let (actions, nonOptions, errors) = getOpt RequireOrder optDescrs args+        options  = foldl (.) id actions defaultOptions++    case errors of+        [] -> return ()+        _ -> do+            mapM_ (hPutStr stderr) errors+            exitFailure++    case nonOptions of+      [] -> failWithUsage+      names -> process options names+    where+      failWithUsage = do+        hPutStrLn stderr "usage: haskell-gi [options] module1 [module2 [...]]"+        hPutStr stderr showHelp+        exitFailure