haskell-gi-0.26.12/0000755000000000000000000000000007346545000012073 5ustar0000000000000000haskell-gi-0.26.12/ChangeLog.md0000644000000000000000000001642607346545000014255 0ustar0000000000000000### 0.26.12 + Add support for the .gir format dialect generated by vala. ### 0.26.11 + Don't try to guess which callback arguments are `user_data` arguments, as this can lead to problems, as in [issue 447](https://github.com/haskell-gi/haskell-gi/issues/447). ### 0.26.9 + Add a workaround for a [GHC issue](https://gitlab.haskell.org/ghc/ghc/-/issues/23392) stopping parallel compilation in GHC >= 9.6. + Fix compilation issues regarding `time_t` and similar types in introspection data. ### 0.26.8 + Add support for scope type "forever": see [this issue](https://github.com/haskell-gi/haskell-gi/issues/425). ### 0.26.7 + Work around changing conventions on how to annotate user_data arguments in callbacks, see [this gobject introspection issue](https://gitlab.gnome.org/GNOME/gobject-introspection/-/issues/450) for background. ### 0.26.6 + Work around changing conventions about what the `closure n` annotation means: many annotations appear on the callback, pointing to the user_data argument, but sometimes it also appears on the user_data argument, pointing to the callback. See [issue 407](https://github.com/haskell-gi/haskell-gi/issues/407) for a place where this becomes a problem. ### 0.26.5 + Add a reference to ?self argument in signals. See [issue 408](https://github.com/haskell-gi/haskell-gi/issues/408) for the motivation. ### 0.26.0 + Support for 'HasField' methods, which allows the syntax 'widget.show' or 'widget.add child' for invoking methods using the new [RecordDotSyntax](https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0282-record-dot-syntax.rst) in ghc 9.2. + And an implicit '?self' parameter for callbacks, for accessing the calling object. See [issue 346](https://github.com/haskell-gi/haskell-gi/issues/346) where this is necessary in practice in gtk4 to use event controllers. + Add an 'After' attribute to connect to signals after the default handler on constructors/setters using attribute syntax, similar to [On](https://hackage.haskell.org/package/haskell-gi-base/docs/Data-GI-Base-Attributes.html#t:AttrOp). + Add [resolveSignal](https://hackage.haskell.org/package/haskell-gi-base-0.26.0/docs/Data-GI-Base-Signals.html#v:resolveSignal) for showing what an overloaded signal resolves to: `resolveSignal button #notify` will output [GI.GObject.Objects.Object.Object::notify](https://hackage.haskell.org/package/gi-gobject-2.0.27/docs/GI-GObject-Objects-Object.html#g:signal:notify). ### 0.25.0 + Support non-GObject object attributes. + Support for ghc 9.0.1. + Improvements in the generated Haddocks. + Remove the command line version of the bindings generator. + Remove support for non-IsLabel overloading. + Add [resolveMethod](https://hackage.haskell.org/package/haskell-gi-base-0.25.0/docs/Data-GI-Base-Overloading.html#v:resolveMethod) for showing what an overloaded method resolves to: `resolveMethod #show widget` will output `GI.Gtk.Objects.Widget.widgetShow`. ### 0.24.5 + Fix an accidental double free for GValues, see [issue 320](https://github.com/haskell-gi/haskell-gi/issues/320). + Accept docsections in gir files, although they are currently ignored. See [issue 318](https://github.com/haskell-gi/haskell-gi/issues/318). ### 0.24.4 + Relax bound on ansi-terminal. ### 0.24.3 + Provide type init functions for GParamSpec types. This solves a puzzling linker error saying that the "intern" symbol could not be resolved, see [issue 297](https://github.com/haskell-gi/haskell-gi/issues/297) and [issue 298](https://github.com/haskell-gi/haskell-gi/issues/298). ### 0.24.2 + Support for allocating GArrays of known size structs in caller-allocates arguments. ### 0.24.1 + Add support for delete-attr override, to remove attributes. + Allow (but ignore) destroyers in scope async callbacks. ### 0.24.0 + Added support for non-GObject objects ### 0.23.2 + Fix a possible segfault in functions that return an out pointer to a dynamically allocated array, but do not initialize the array if it has zero size. See [#289](https://github.com/haskell-gi/haskell-gi/issues/289) for an example. ### 0.23.1 + Check whether symbols exist in the dynamic library before trying to generate bindings for them, in order to avoid linker errors. ### 0.23.0 + gobjectType now does not require a proxy argument, it needs to be used with TypeApplications instead. + Annotated signals are supported: `on widget (signal ::: "detail")`. + Safe coercions to parent types supported, with `asA`. + Support for GObject subclassing, and registering custom properties. + Use TypeApplications in `AttrInfo` implementation, and inherited methods implementation. + Add an allocating setting operator `(:&=)`. + Support for exporting class structs. + IsGValue instances for GObjects and boxed objects. ### 0.22.6 + Fix generated IsX typeclasses for non-GObject interfaces. ### 0.22.5 + Add support for inheriting overloading info. ### 0.22.4 + Do not generate bindings for struct/union fields pointing to private/class structs, which we do not bind. ### 0.22.3 + Sometimes struct fields marked as not introspectable contain invalid introspection info. We are lenient in these cases with parsing errors, and simply ignore the fields. ### 0.21.5 + Add support for callback-valued properties. ### 0.21.4 + Try to guess signedness of enums and flags on the C side, fixes [#184](https://github.com/haskell-gi/haskell-gi/issues/184). ### 0.21.3 + Do not add nodes in overrides if a node with the same name already exists, fixes [#171](https://github.com/haskell-gi/haskell-gi/issues/171). ### 0.21.2 + Do not free `Ptr Word8` types after performing the call to C, since they only get passed along. Otherwise one could easily double free in functions such as [GdkPixbuf.pixbufNewFromData](https://hackage.haskell.org/package/gi-gdkpixbuf/docs/GI-GdkPixbuf-Objects-Pixbuf.html#v:pixbufNewFromData). + Fix a leak on optional `ScopeTypeAsync` callbacks. ### 0.20.4 + Improve marshaling of array arguments with no specified size. This improves the generated bindings for various functions, for instance [`GObject.signalEmitv`](https://hackage.haskell.org/package/gi-gobject/docs/GI-GObject-Functions.html#v:signalEmitv). + Replace the enable-overloading flags with a explicit CPP check of the version of `haskell-gi-overloading` we are being compiled against, see [issue 124](https://github.com/haskell-gi/haskell-gi/issues/124) for the rationale. ### 0.20.3 + Make the overloading code protected by a CPP conditional, depending on ENABLE_OVERLOADING being defined. See [issue 107](https://github.com/haskell-gi/haskell-gi/issues/107). + Wrap boxed structs/unions as transient [ManagedPtr](https://hackage.haskell.org/package/haskell-gi-base/docs/Data-GI-Base-BasicTypes.html#t:ManagedPtr)s in callbacks. This is needed to fix a number of issues, including [issue 96](https://github.com/haskell-gi/haskell-gi/issues/96) and [issue 97](https://github.com/haskell-gi/haskell-gi/issues/97). ### 0.20.2 + Fixes for GHC 8.2.1. ### 0.20.1 + gtk-doc parser and haddock generator: while by no means perfect, now the autogenerated bindings come with some reasonable autogenerated documentation. + Many bugfixes. A particularly important one is for [issue 82](https://github.com/haskell-gi/haskell-gi/issues/82), which made compilation of [gi-glib](http://hackage.haskell.org/package/gi-glib) fail, for the latest version of gobject-introspection. haskell-gi-0.26.12/DocTests.hs0000644000000000000000000000102107346545000014151 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} module Main where import Build_doctests (flags, pkgs, module_sources) import Test.DocTest (doctest) import System.Process main :: IO () main = do gobjectIntrospectionLibs <- pkgConfigLibs "gobject-introspection-1.0" -- traverse_ putStrLn args -- optionally print arguments doctest (gobjectIntrospectionLibs ++ args) where args = flags ++ pkgs ++ module_sources pkgConfigLibs :: String -> IO [String] pkgConfigLibs pkg = words <$> readProcess "pkg-config" ["--libs", pkg] "" haskell-gi-0.26.12/LICENSE0000644000000000000000000006106707346545000013112 0ustar0000000000000000The haskell-gi library and included works are provided under the terms of the GNU Library General Public License (LGPL) version 2.1 with the following exception: Static linking of applications or any other source to the haskell-gi library does not constitute a modified or derivative work and does not require the author(s) to provide source code for said work, to link against the shared haskell-gi libraries, or to link their applications against a user-supplied version of haskell-gi. If you link applications to a modified version of haskell-gi, then the changes to haskell-gi must be provided under the terms of the LGPL. ---------------------------------------------------------------------------- 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. haskell-gi-0.26.12/Setup.hs0000644000000000000000000000021007346545000013520 0ustar0000000000000000module Main where import Distribution.Extra.Doctest (defaultMainWithDoctests) main :: IO () main = defaultMainWithDoctests "doctests" haskell-gi-0.26.12/haskell-gi.cabal0000644000000000000000000001203607346545000015101 0ustar0000000000000000name: haskell-gi version: 0.26.12 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 and Iñaki García Etxebarria maintainer: Iñaki García Etxebarria (github@the.blueleaf.cc) stability: Experimental category: Development build-type: Custom tested-with: GHC == 8.4.1, GHC == 8.6.1, GHC == 8.8.1, GHC == 8.10.1, GHC == 9.0.1, GHC == 9.2.1 cabal-version: 2.0 extra-source-files: ChangeLog.md custom-setup setup-depends: base >= 4 && <5, Cabal >= 1.24 && < 4, cabal-doctest >= 1 source-repository head type: git location: git://github.com/haskell-gi/haskell-gi.git Library default-language: Haskell2010 pkgconfig-depends: gobject-introspection-1.0 >= 1.32, gobject-2.0 >= 2.32 build-depends: base >= 4.11 && < 5, haskell-gi-base >= 0.26.5 && <0.27, Cabal >= 1.24, attoparsec >= 0.13, containers, directory, filepath, mtl >= 2.2, transformers >= 0.3, pretty-show, ansi-terminal >= 0.10, process, safe, bytestring, xdg-basedir, xml-conduit >= 1.3, regex-tdfa >= 1.2, text >= 1.0 default-extensions: CPP, ForeignFunctionInterface, DoAndIfThenElse, LambdaCase, RankNTypes, OverloadedStrings ghc-options: -Wall -fwarn-incomplete-patterns -fno-warn-name-shadowing -Wcompat c-sources: lib/c/enumStorage.c build-tool-depends: hsc2hs:hsc2hs hs-source-dirs: lib exposed-modules: Data.GI.GIR.Alias, Data.GI.GIR.Allocation, Data.GI.GIR.Arg, Data.GI.GIR.BasicTypes, Data.GI.GIR.Callable, Data.GI.GIR.Callback, Data.GI.GIR.Constant, Data.GI.GIR.Deprecation, Data.GI.GIR.Documentation, Data.GI.GIR.Enum, Data.GI.GIR.Field, Data.GI.GIR.Flags, Data.GI.GIR.Function, Data.GI.GIR.Interface, Data.GI.GIR.Method, Data.GI.GIR.Object, Data.GI.GIR.Parser, Data.GI.GIR.Property, Data.GI.GIR.Repository, Data.GI.GIR.Signal, Data.GI.GIR.Struct, Data.GI.GIR.Type, Data.GI.GIR.Union, Data.GI.GIR.XMLUtils, Data.GI.CodeGen.API, Data.GI.CodeGen.CabalHooks, Data.GI.CodeGen.Callable, Data.GI.CodeGen.Code, Data.GI.CodeGen.CodeGen, Data.GI.CodeGen.Config, Data.GI.CodeGen.Constant, Data.GI.CodeGen.Conversions, Data.GI.CodeGen.CtoHaskellMap, Data.GI.CodeGen.EnumFlags, Data.GI.CodeGen.Fixups, Data.GI.CodeGen.GObject, Data.GI.CodeGen.GtkDoc, Data.GI.CodeGen.GType, Data.GI.CodeGen.Haddock, Data.GI.CodeGen.Inheritance, Data.GI.CodeGen.LibGIRepository, Data.GI.CodeGen.ModulePath, Data.GI.CodeGen.OverloadedSignals, Data.GI.CodeGen.OverloadedMethods, Data.GI.CodeGen.Overrides, Data.GI.CodeGen.PkgConfig, Data.GI.CodeGen.ProjectInfo, Data.GI.CodeGen.Properties, Data.GI.CodeGen.Signal, Data.GI.CodeGen.Struct, Data.GI.CodeGen.SymbolNaming, Data.GI.CodeGen.Transfer, Data.GI.CodeGen.Type, Data.GI.CodeGen.Util other-modules: Paths_haskell_gi autogen-modules: Paths_haskell_gi test-suite doctests type: exitcode-stdio-1.0 default-language: Haskell2010 ghc-options: -threaded -Wall main-is: DocTests.hs build-depends: base , process , doctest >= 0.8 , haskell-gi >= 0.26.10 haskell-gi-0.26.12/lib/Data/GI/CodeGen/0000755000000000000000000000000007346545000015315 5ustar0000000000000000haskell-gi-0.26.12/lib/Data/GI/CodeGen/API.hs0000644000000000000000000006740607346545000016277 0ustar0000000000000000{-# LANGUAGE RecordWildCards, NamedFieldPuns #-} module Data.GI.CodeGen.API ( API(..) , GIRInfo(..) , loadGIRInfo , loadRawGIRInfo , GIRRule(..) , GIRPath , GIRNodeSpec(..) , GIRNameTag(..) -- Reexported from Data.GI.GIR.BasicTypes , Name(..) , Transfer(..) -- Reexported from Data.GI.GIR.Allocation , AllocationInfo(..) , AllocationOp(..) , unknownAllocationInfo -- Reexported from Data.GI.GIR.Arg , Direction(..) , Scope(..) -- Reexported from Data.GI.GIR.Deprecation , DeprecationInfo -- Reexported from Data.GI.GIR.Enumeration , EnumerationMember(..) -- Reexported from Data.GI.GIR.Property , PropertyFlag(..) -- Reexported from Data.GI.GIR.Method , MethodType(..) -- Reexported from the corresponding Data.GI.GIR modules , Constant(..) , Arg(..) , Callable(..) , Function(..) , Signal(..) , Property(..) , Field(..) , Struct(..) , Callback(..) , Interface(..) , Method(..) , Object(..) , Enumeration(..) , Flags (..) , Union (..) ) where #if !MIN_VERSION_base(4,8,0) import Control.Applicative ((<$>)) #endif import Control.Monad ((>=>), foldM, forM, when) import qualified Data.List as L import qualified Data.Map as M import Data.Maybe (mapMaybe, catMaybes) #if !MIN_VERSION_base(4,11,0) import Data.Monoid ((<>)) #endif 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 qualified Text.XML as XML import Text.Regex.TDFA ((=~)) import Data.GI.GIR.Alias (documentListAliases) import Data.GI.GIR.Allocation (AllocationInfo(..), AllocationOp(..), unknownAllocationInfo) import Data.GI.GIR.Arg (Arg(..), Direction(..), Scope(..)) import Data.GI.GIR.BasicTypes (Alias, Name(..), Transfer(..)) import Data.GI.GIR.Callable (Callable(..)) import Data.GI.GIR.Callback (Callback(..), parseCallback) import Data.GI.GIR.Constant (Constant(..), parseConstant) import Data.GI.GIR.Deprecation (DeprecationInfo) import Data.GI.GIR.Enum (Enumeration(..), EnumerationMember(..), parseEnum) import Data.GI.GIR.Field (Field(..)) import Data.GI.GIR.Flags (Flags(..), parseFlags) import Data.GI.GIR.Function (Function(..), parseFunction) import Data.GI.GIR.Interface (Interface(..), parseInterface) import Data.GI.GIR.Method (Method(..), MethodType(..)) import Data.GI.GIR.Object (Object(..), parseObject) import Data.GI.GIR.Parser (Parser, runParser) import Data.GI.GIR.Property (Property(..), PropertyFlag(..)) import Data.GI.GIR.Repository (readGiRepository) import Data.GI.GIR.Signal (Signal(..)) import Data.GI.GIR.Struct (Struct(..), parseStruct) import Data.GI.GIR.Union (Union(..), parseUnion) import Data.GI.GIR.XMLUtils (subelements, childElemsWithLocalName, lookupAttr, lookupAttrWithNamespace, GIRXMLNamespace(..), xmlLocalName) import Data.GI.Base.BasicConversions (unpackStorableArrayWithLength) import Data.GI.Base.BasicTypes (GType(..), CGType, gtypeName) import Data.GI.Base.Utils (allocMem, freeMem) import Data.GI.CodeGen.LibGIRepository (girRequire, Typelib, FieldInfo(..), girStructFieldInfo, girUnionFieldInfo, girLoadGType, girIsSymbolResolvable) import Data.GI.CodeGen.GType (gtypeIsBoxed) import Data.GI.CodeGen.Type (Type) import Data.GI.CodeGen.Util (printWarning, terror, tshow) 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) -- | Path to a node in the GIR file, starting from the document root -- of the GIR file. This is a very simplified version of something -- like XPath. type GIRPath = [GIRNodeSpec] -- | Node selector for a path in the GIR file. data GIRNodeSpec = GIRNamed GIRNameTag -- ^ Node with the given "name" attr. | GIRType Text -- ^ Node of the given type. | GIRTypedName Text GIRNameTag -- ^ Combination of the above. deriving (Show) -- | A name tag, which is either a name or a regular expression. data GIRNameTag = GIRPlainName Text | GIRRegex Text deriving (Show) -- | A rule for modifying the GIR file. data GIRRule = GIRSetAttr (GIRPath, XML.Name) Text -- ^ (Path to element, -- attrName), newValue. | GIRDeleteAttr GIRPath XML.Name -- ^ Delete the given attribute | GIRAddNode GIRPath XML.Name -- ^ Add a child node at -- the given selector. | GIRDeleteNode GIRPath -- ^ Delete any nodes matching -- the given selector. deriving (Show) -- | An element in the exposed API 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 "docsection" -> ns -- Ignored for now, see https://github.com/haskell-gi/haskell-gi/issues/318 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 -> [GIRRule] -- ^ fixups -> IO (M.Map (Text, Text) Document) -- ^ New loaded set loadDependencies verbose requested loaded extraPaths rules | S.null requested = return loaded | otherwise = do let (name, version) = S.elemAt 0 requested doc <- overrideGIRDocument rules <$> readGiRepository verbose name (Just version) extraPaths let newLoaded = M.insert (name, version) doc loaded loadedSet = S.fromList (M.keys newLoaded) newRequested = S.union requested (documentListIncludes doc) notYetLoaded = S.difference newRequested loadedSet loadDependencies verbose notYetLoaded newLoaded extraPaths rules -- | Load a given GIR file and recursively its dependencies loadGIRFile :: Bool -- ^ verbose -> Text -- ^ name -> Maybe Text -- ^ version -> [FilePath] -- ^ extra paths to search -> [GIRRule] -- ^ overrides -> IO (Document, M.Map (Text, Text) Document) -- ^ (loaded doc, dependencies) loadGIRFile verbose name version extraPaths rules = do doc <- overrideGIRDocument rules <$> readGiRepository verbose name version extraPaths deps <- loadDependencies verbose (documentListIncludes doc) M.empty extraPaths rules 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 -- | Fixup parsed GIRInfos: some of the required information is not -- found in the GIR files themselves, or does not accurately reflect -- the content in the dynamic library itself, but this can be -- corrected by checking the typelib. fixupGIRInfos :: Bool -> M.Map Text Typelib -> GIRInfo -> [GIRInfo] -> IO (GIRInfo, [GIRInfo]) fixupGIRInfos verbose typelibMap doc deps = (fixup (fixupInterface typelibMap ctypes) >=> fixup (fixupStruct typelibMap) >=> fixup fixupUnion >=> fixup (fixupMissingSymbols verbose typelibMap) ) (doc, deps) where fixup :: ((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 :: ((Name, API) -> IO (Name, API)) -> GIRInfo -> IO GIRInfo fixAPIs fixer info = do fixedAPIs <- mapM fixer (girAPIs info) return $ info {girAPIs = fixedAPIs} ctypes :: M.Map Text Name ctypes = M.unions (map girCTypes (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 Typelib -> M.Map Text Name -> (Name, API) -> IO (Name, API) fixupInterface typelibMap csymbolMap (n@(Name ns _), APIInterface iface) = do prereqs <- case ifTypeInit iface of Nothing -> return [] Just ti -> do gtype <- case M.lookup ns typelibMap of Just typelib -> girLoadGType typelib ti Nothing -> error $ "fi: Typelib for " ++ show ns ++ " not loaded." 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 Typelib -> (Name, API) -> IO (Name, API) fixupStruct typelibMap (n, APIStruct s) = do fixed <- (fixupStructIsBoxed typelibMap n >=> fixupStructSizeAndOffsets n) s return (n, APIStruct fixed) fixupStruct _ api = return api -- | Find out whether the struct is boxed. fixupStructIsBoxed :: M.Map Text Typelib -> 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 typelibMap (Name ns _) s = do isBoxed <- case structTypeInit s of Nothing -> return False Just ti -> do gtype <- case M.lookup ns typelibMap of Just typelib -> girLoadGType typelib ti Nothing -> error $ "fsib: Typelib for " ++ show ns ++ " not loaded." 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, infoMap) <- girStructFieldInfo ns n return (s { structSize = size , structFields = map (fixupField infoMap) (structFields s)}) -- | Same thing for unions. fixupUnion :: (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, infoMap) <- girUnionFieldInfo ns n return (u { unionSize = size , unionFields = map (fixupField infoMap) (unionFields u)}) -- | Fixup the offsets of fields using the given offset map. fixupField :: M.Map Text FieldInfo -> 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 -> fieldInfoOffset o } -- | Some of the symbols listed in the introspection data are not -- present in the dynamic library itself. Generating bindings for -- these will sometimes lead to linker errors, so here we check that -- every symbol listed in the bindings is actually present. fixupMissingSymbols :: Bool -> M.Map Text Typelib -> (Name, API) -> IO (Name, API) fixupMissingSymbols verbose typelibMap (n, APIStruct s) = do fixedMethods <- fixupMethodMissingSymbols (resolveTypelib n typelibMap) (structMethods s) verbose return (n, APIStruct (s {structMethods = fixedMethods})) fixupMissingSymbols verbose typelibMap (n, APIUnion u) = do fixedMethods <- fixupMethodMissingSymbols (resolveTypelib n typelibMap) (unionMethods u) verbose return (n, APIUnion (u {unionMethods = fixedMethods})) fixupMissingSymbols verbose typelibMap (n, APIObject o) = do fixedMethods <- fixupMethodMissingSymbols (resolveTypelib n typelibMap) (objMethods o) verbose return (n, APIObject (o {objMethods = fixedMethods})) fixupMissingSymbols verbose typelibMap (n, APIInterface i) = do fixedMethods <- fixupMethodMissingSymbols (resolveTypelib n typelibMap) (ifMethods i) verbose return (n, APIInterface (i {ifMethods = fixedMethods})) fixupMissingSymbols verbose typelibMap (n, APIFunction f) = fixupFunctionSymbols typelibMap (n, f) verbose fixupMissingSymbols _ _ (n, api) = return (n, api) -- | Resolve the typelib owning the given name, erroring out if the -- typelib is not known. resolveTypelib :: Name -> M.Map Text Typelib -> Typelib resolveTypelib n typelibMap = case M.lookup (namespace n) typelibMap of Nothing -> terror $ "Could not find typelib for “" <> namespace n <> "”." Just typelib -> typelib -- | Mark whether the methods can be resolved in the given typelib. fixupMethodMissingSymbols :: Typelib -> [Method] -> Bool -> IO [Method] fixupMethodMissingSymbols typelib methods verbose = mapM check methods where check :: Method -> IO Method check method@Method{methodCallable = callable} = do resolvable <- girIsSymbolResolvable typelib (methodSymbol method) when (verbose && not resolvable) $ printWarning $ "Could not resolve the callable “" <> methodSymbol method <> "” in the “" <> tshow typelib <> "” typelib, ignoring." let callable' = callable{callableResolvable = Just resolvable} return $ method{methodCallable = callable'} -- | Check that the symbol the function refers to is actually present -- in the dynamic library. fixupFunctionSymbols :: M.Map Text Typelib -> (Name, Function) -> Bool -> IO (Name, API) fixupFunctionSymbols typelibMap (n, f) verbose = do let typelib = resolveTypelib n typelibMap resolvable <- girIsSymbolResolvable typelib (fnSymbol f) when (verbose && not resolvable) $ printWarning $ "Could not resolve the function “" <> fnSymbol f <> "” in the “" <> tshow typelib <> "” typelib, ignoring." let callable' = (fnCallable f){callableResolvable = Just resolvable} return (n, APIFunction (f {fnCallable = callable'})) -- | Load and parse a GIR file, including its dependencies. loadGIRInfo :: Bool -- ^ verbose -> Text -- ^ name -> Maybe Text -- ^ version -> [FilePath] -- ^ extra paths to search -> [GIRRule] -- ^ fixups -> IO (GIRInfo, [GIRInfo]) -- ^ (parsed doc, parsed deps) loadGIRInfo verbose name version extraPaths rules = do (doc, deps) <- loadGIRFile verbose name version extraPaths rules 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 typelibMap <- M.fromList <$> (forM (docGIR : depsGIR) $ \info -> do typelib <- girRequire (girNSName info) (girNSVersion info) return (girNSName info, typelib)) (fixedDoc, fixedDeps) <- fixupGIRInfos verbose typelibMap 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) -- | Given a XML document containing GIR data, apply the given overrides. overrideGIRDocument :: [GIRRule] -> XML.Document -> XML.Document overrideGIRDocument rules doc = doc {XML.documentRoot = overrideGIR rules (XML.documentRoot doc)} -- | Looks for the given path in the given subelements of the given -- element. If the path is empty apply the corresponding rule, -- otherwise return the element ummodified. overrideGIR :: [GIRRule] -> XML.Element -> XML.Element overrideGIR rules elem = elem {XML.elementNodes = mapMaybe (\e -> foldM applyGIRRule e rules) (XML.elementNodes elem)} where applyGIRRule :: XML.Node -> GIRRule -> Maybe XML.Node applyGIRRule n (GIRSetAttr (path, attr) newVal) = Just $ girSetAttr (path, attr) newVal n applyGIRRule n (GIRDeleteAttr path attr) = Just $ girDeleteAttr path attr n applyGIRRule n (GIRAddNode path new) = Just $ girAddNode path new n applyGIRRule n (GIRDeleteNode path) = girDeleteNodes path n -- | Set an attribute for the child element specified by the given -- path. girSetAttr :: (GIRPath, XML.Name) -> Text -> XML.Node -> XML.Node girSetAttr (spec:rest, attr) newVal n@(XML.NodeElement elem) = if specMatch spec n then case rest of -- Matched the full path, apply [] -> XML.NodeElement (elem {XML.elementAttributes = M.insert attr newVal (XML.elementAttributes elem)}) -- Still some selectors to apply _ -> XML.NodeElement (elem {XML.elementNodes = map (girSetAttr (rest, attr) newVal) (XML.elementNodes elem)}) else n girSetAttr _ _ n = n -- | Delete an attribute for the child element specified by the given -- path, if the attribute exists. girDeleteAttr :: GIRPath -> XML.Name -> XML.Node -> XML.Node girDeleteAttr (spec:rest) attr n@(XML.NodeElement elem) = if specMatch spec n then case rest of -- Matched the full path, apply [] -> XML.NodeElement (elem {XML.elementAttributes = M.delete attr (XML.elementAttributes elem)}) -- Still some selectors to apply _ -> XML.NodeElement (elem {XML.elementNodes = map (girDeleteAttr rest attr) (XML.elementNodes elem)}) else n girDeleteAttr _ _ n = n -- | Add the given subnode to any nodes matching the given path girAddNode :: GIRPath -> XML.Name -> XML.Node -> XML.Node girAddNode (spec:rest) newNode n@(XML.NodeElement element) = if specMatch spec n then case rest of -- Matched the full path, add the new child node. [] -> let newElement = XML.Element { elementName = newNode , elementAttributes = M.empty , elementNodes = [] } -- We only insert if not present, see #171. For -- convenience when writing the override files, we -- ignore the namespace when comparing. nodeElementName (XML.NodeElement e) = (Just . nameLocalName . elementName) e nodeElementName _ = Nothing nodeNames = mapMaybe nodeElementName (XML.elementNodes element) in if nameLocalName newNode `elem` nodeNames then n else XML.NodeElement (element {XML.elementNodes = XML.elementNodes element <> [XML.NodeElement newElement]}) -- Still some selectors to apply. _ -> XML.NodeElement (element {XML.elementNodes = map (girAddNode rest newNode) (XML.elementNodes element)}) else n girAddNode _ _ n = n -- | Delete any nodes matching the given path. girDeleteNodes :: GIRPath -> XML.Node -> Maybe XML.Node girDeleteNodes (spec:rest) n@(XML.NodeElement elem) = if specMatch spec n then case rest of -- Matched the full path, discard the node [] -> Nothing -- More selectors to apply _ -> Just $ XML.NodeElement (elem {XML.elementNodes = mapMaybe (girDeleteNodes rest) (XML.elementNodes elem)}) else Just n girDeleteNodes _ n = Just n -- | Lookup the given attribute and if present see if it matches the -- given regex. lookupAndMatch :: GIRNameTag -> M.Map XML.Name Text -> XML.Name -> Bool lookupAndMatch tag attrs attr = case M.lookup attr attrs of Just s -> case tag of GIRPlainName pn -> s == pn GIRRegex r -> T.unpack s =~ T.unpack r Nothing -> False -- | See if a given node specification applies to the given node. specMatch :: GIRNodeSpec -> XML.Node -> Bool specMatch (GIRType t) (XML.NodeElement elem) = XML.nameLocalName (XML.elementName elem) == t specMatch (GIRNamed name) (XML.NodeElement elem) = lookupAndMatch name (XML.elementAttributes elem) (xmlLocalName "name") specMatch (GIRTypedName t name) (XML.NodeElement elem) = XML.nameLocalName (XML.elementName elem) == t && lookupAndMatch name (XML.elementAttributes elem) (xmlLocalName "name") specMatch _ _ = False haskell-gi-0.26.12/lib/Data/GI/CodeGen/CabalHooks.hs0000644000000000000000000001654007346545000017665 0ustar0000000000000000-- | Convenience hooks for writing custom @Setup.hs@ files for -- bindings. module Data.GI.CodeGen.CabalHooks ( setupBinding , configureDryRun , TaggedOverride(..) ) where import qualified Distribution.ModuleName as MN import Distribution.Simple.LocalBuildInfo import Distribution.Simple.Setup import Distribution.Simple (UserHooks(..), simpleUserHooks, defaultMainWithHooks, OptimisationLevel(..)) import Distribution.PackageDescription import Data.GI.CodeGen.API (loadGIRInfo) import Data.GI.CodeGen.Code (genCode, writeModuleTree, listModuleTree, ModuleInfo, transitiveModuleDeps) import Data.GI.CodeGen.CodeGen (genModule) import Data.GI.CodeGen.Config (Config(..)) import Data.GI.CodeGen.LibGIRepository (setupTypelibSearchPath) import Data.GI.CodeGen.ModulePath (toModulePath) import Data.GI.CodeGen.Overrides (parseOverrides, girFixups, filterAPIsAndDeps) import Data.GI.CodeGen.Util (utf8ReadFile, utf8WriteFile, ucFirst) import System.Directory (createDirectoryIfMissing) import System.FilePath (joinPath, takeDirectory) import Control.Monad (void, forM) import Data.Maybe (fromJust, fromMaybe) import qualified Data.Map as M #if !MIN_VERSION_base(4,11,0) import Data.Monoid ((<>)) #endif import qualified Data.Set as S import Data.Text (Text) import qualified Data.Text as T type ConfHook = (GenericPackageDescription, HookedBuildInfo) -> ConfigFlags -> IO LocalBuildInfo -- | Included overrides file. data TaggedOverride = TaggedOverride { overrideTag :: Text -- ^ Tag for the override, for error reporting purposes. , overrideText :: Text } -- | Generate the code for the given module. genModuleCode :: Text -- ^ name -> Text -- ^ version -> Text -- ^ pkgName -> Text -- ^ pkgVersion -> Bool -- ^ verbose -> [TaggedOverride] -- ^ Explicit overrides -> IO ModuleInfo genModuleCode name version pkgName pkgVersion verbosity overrides = do setupTypelibSearchPath [] parsed <- forM overrides $ \(TaggedOverride tag ovText) -> do parseOverrides ovText >>= \case Left err -> error $ "Error when parsing overrides file \"" <> T.unpack tag <> "\":" <> T.unpack err Right ovs -> return ovs let ovs = mconcat parsed (gir, girDeps) <- loadGIRInfo verbosity name (Just version) [] (girFixups ovs) let (apis, deps) = filterAPIsAndDeps ovs gir girDeps allAPIs = M.union apis deps cfg = Config {modName = name, modVersion = version, ghcPkgName = pkgName, ghcPkgVersion = pkgVersion, verbose = verbosity, overrides = ovs} return $ genCode cfg allAPIs (toModulePath name) (genModule apis) -- | Write a module containing information about the configuration for -- the package. genConfigModule :: Maybe FilePath -> Text -> Maybe TaggedOverride -> IO () genConfigModule outputDir modName maybeGiven = do let fname = joinPath [ fromMaybe "" outputDir , "GI" , T.unpack (ucFirst modName) , "Config.hs" ] dirname = takeDirectory fname createDirectoryIfMissing True dirname utf8WriteFile fname $ T.unlines [ "{-# LANGUAGE OverloadedStrings #-}" , "-- | Build time configuration used during code generation." , "module GI." <> ucFirst modName <> ".Config ( overrides ) where" , "" , "import qualified Data.Text as T" , "import Data.Text (Text)" , "" , "-- | Overrides used when generating these bindings." , "overrides :: Text" , "overrides = T.unlines" , " [ " <> T.intercalate "\n , " (quoteOverrides maybeGiven) <> "]" ] where quoteOverrides :: Maybe TaggedOverride -> [Text] quoteOverrides Nothing = [] quoteOverrides (Just (TaggedOverride _ ovText)) = map (T.pack . show) (T.lines ovText) -- | A convenience helper for `confHook`, such that bindings for the -- given module are generated in the @configure@ step of @cabal@. confCodeGenHook :: Text -- ^ name -> Text -- ^ version -> Text -- ^ pkgName -> Text -- ^ pkgVersion -> Bool -- ^ verbose -> Maybe FilePath -- ^ overrides file -> [TaggedOverride] -- ^ other overrides -> Maybe FilePath -- ^ output dir -> ConfHook -- ^ previous `confHook` -> ConfHook confCodeGenHook name version pkgName pkgVersion verbosity overridesFile inheritedOverrides outputDir defaultConfHook (gpd, hbi) flags = do givenOvs <- traverse (\fname -> TaggedOverride (T.pack fname) <$> utf8ReadFile fname) overridesFile let ovs = maybe inheritedOverrides (:inheritedOverrides) givenOvs m <- genModuleCode name version pkgName pkgVersion verbosity ovs let buildInfo = MN.fromString . T.unpack $ "GI." <> ucFirst name <> ".Config" em' = buildInfo : map (MN.fromString . T.unpack) (listModuleTree m) lib = ((condTreeData . fromJust . condLibrary) gpd) bi = libBuildInfo lib #if MIN_VERSION_base(4,11,0) bi' = bi {autogenModules = em'} #else bi' = bi #endif lib' = lib {exposedModules = em', libBuildInfo = bi'} cL' = ((fromJust . condLibrary) gpd) {condTreeData = lib'} gpd' = gpd {condLibrary = Just cL'} void $ writeModuleTree verbosity outputDir m genConfigModule outputDir name givenOvs lbi <- defaultConfHook (gpd', hbi) flags return (lbi {withOptimization = NoOptimisation}) -- | The entry point for @Setup.hs@ files in bindings. setupBinding :: Text -- ^ name -> Text -- ^ version -> Text -- ^ pkgName -> Text -- ^ pkgVersion -> Bool -- ^ verbose -> Maybe FilePath -- ^ overrides file -> [TaggedOverride] -- ^ Explicit overrides -> Maybe FilePath -- ^ output dir -> IO () setupBinding name version pkgName pkgVersion verbose overridesFile overrides outputDir = defaultMainWithHooks (simpleUserHooks { confHook = confCodeGenHook name version pkgName pkgVersion verbose overridesFile overrides outputDir (confHook simpleUserHooks) }) -- | Return the list of modules that `setupHaskellGIBinding` would -- create, together with the set of dependencies loaded while -- generating the code. configureDryRun :: Text -- ^ name -> Text -- ^ version -> Text -- ^ pkgName -> Text -- ^ pkgVersion -> Maybe FilePath -- ^ Overrides file -> [TaggedOverride] -- ^ Other overrides to load -> IO ([Text], S.Set Text) configureDryRun name version pkgName pkgVersion overridesFile inheritedOverrides = do givenOvs <- traverse (\fname -> TaggedOverride (T.pack fname) <$> utf8ReadFile fname) overridesFile let ovs = maybe inheritedOverrides (:inheritedOverrides) givenOvs m <- genModuleCode name version pkgName pkgVersion False ovs return (("GI." <> ucFirst name <> ".Config") : listModuleTree m, transitiveModuleDeps m) haskell-gi-0.26.12/lib/Data/GI/CodeGen/Callable.hs0000644000000000000000000013106007346545000017351 0ustar0000000000000000{-# LANGUAGE LambdaCase #-} module Data.GI.CodeGen.Callable ( genCCallableWrapper , genDynamicCallableWrapper , ForeignSymbol(..) , hOutType , skipRetVal , arrayLengths , arrayLengthsMap , callableSignature , Signature(..) , fixupCallerAllocates , callableHInArgs , callableHOutArgs , wrapMaybe , inArgInterfaces ) where import Control.Monad (forM, forM_, when, void) import Data.Bool (bool) import Data.List (nub) import Data.Maybe (isJust) #if !MIN_VERSION_base(4,13,0) import Data.Monoid ((<>)) #endif import Data.Tuple (swap) import qualified Data.Map as Map import qualified Data.Text as T import Data.Text (Text) import Data.GI.CodeGen.API import Data.GI.CodeGen.Code import Data.GI.CodeGen.Conversions import Data.GI.CodeGen.Haddock (deprecatedPragma, writeHaddock, writeDocumentation, RelativeDocPosition(..), writeArgDocumentation, writeReturnDocumentation) import Data.GI.CodeGen.SymbolNaming import Data.GI.CodeGen.Transfer import Data.GI.CodeGen.Type import Data.GI.CodeGen.Util import Text.Show.Pretty (ppShow) hOutType :: Callable -> [Arg] -> ExcCodeGen TypeRep hOutType callable outArgs = do hReturnType <- case returnType callable of Nothing -> return $ con0 "()" Just r -> if skipRetVal callable then return $ con0 "()" else haskellType r hOutArgTypes <- forM outArgs $ \outarg -> wrapMaybe outarg >>= bool (haskellType (argType outarg)) (maybeT <$> haskellType (argType outarg)) nullableReturnType <- maybe (return False) typeIsNullable (returnType callable) let maybeHReturnType = if returnMayBeNull callable && not (skipRetVal callable) && nullableReturnType then maybeT hReturnType else hReturnType return $ case (outArgs, typeShow maybeHReturnType) of ([], _) -> maybeHReturnType (_, "()") -> "(,)" `con` hOutArgTypes _ -> "(,)" `con` (maybeHReturnType : hOutArgTypes) -- | Generate a foreign import for the given C symbol. Return the name -- of the corresponding Haskell identifier. mkForeignImport :: Text -> Callable -> CodeGen e Text mkForeignImport cSymbol callable = do line first indent $ do mapM_ (\a -> line =<< fArgStr a) (args callable) when (callableThrows callable) $ line $ padTo 40 "Ptr (Ptr GError) -> " <> "-- error" line =<< last return hSymbol where hSymbol = if T.any (== '_') cSymbol then lcFirst cSymbol else "_" <> cSymbol first = "foreign import ccall \"" <> cSymbol <> "\" " <> hSymbol <> " :: " fArgStr arg = do ft <- foreignType $ argType arg let ft' = if direction arg == DirectionIn || argCallerAllocates arg then ft else ptr ft let start = typeShow ft' <> " -> " return $ padTo 40 start <> "-- " <> (argCName arg) <> " : " <> tshow (argType arg) last = typeShow <$> io <$> case returnType callable of Nothing -> return $ con0 "()" Just r -> foreignType r -- | Make a wrapper for foreign `FunPtr`s of the given type. Return -- the name of the resulting dynamic Haskell wrapper. mkDynamicImport :: Text -> CodeGen e Text mkDynamicImport typeSynonym = do line $ "foreign import ccall \"dynamic\" " <> dynamic <> " :: FunPtr " <> typeSynonym <> " -> " <> typeSynonym return dynamic where dynamic = "__dynamic_" <> typeSynonym -- | 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 -> CodeGen e Bool wrapMaybe arg = if mayBeNull arg then typeIsNullable (argType arg) else return False -- | Given the list of arguments returns the list of constraints and the -- list of types in the signature. inArgInterfaces :: [Arg] -> ExposeClosures -> ExcCodeGen ([Text], [Text]) inArgInterfaces args expose = do resetTypeVariableScope go args where go [] = return ([], []) go (arg:args) = do (t, cons) <- argumentType (argType arg) expose t' <- wrapMaybe arg >>= bool (return t) (return $ "Maybe (" <> t <> ")") (restCons, restTypes) <- go 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 Just (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 = escapedArgName length avar = escapedArgName 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 let name = lowerName n funcName = namespace n <> "." <> name lvar = escapedArgName length avar = escapedArgName array expectedLength = avar <> "_expected_length_" pvar = escapedArgName 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 skipRetVal callable = (skipReturn callable) || (callableThrows callable && returnType callable == Just (TBasicType TBoolean)) freeInArgs' :: (Arg -> Text -> Text -> ExcCodeGen [Text]) -> Callable -> Map.Map Text Text -> ExcCodeGen [Text] freeInArgs' freeFn callable nameMap = concat <$> actions where actions :: ExcCodeGen [[Text]] actions = forM (args callable) $ \arg -> case Map.lookup (escapedArgName 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) _ -> parenthesize ("length " <> escapedArgName arg) TCArray False (-1) length _ -> escapedArgName $ (args callable)!!length _ -> undefined Nothing -> badIntroError $ "freeInArgs: do not understand " <> tshow 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 :: Callable -> Map.Map Text Text -> ExcCodeGen [Text] 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 :: Callable -> Map.Map Text Text -> ExcCodeGen [Text] 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 -> ExposeClosures -> ExcCodeGen Text prepareArgForCall omitted arg expose = do callback <- findAPI (argType arg) >>= \case Just (APICallback c) -> return (Just c) _ -> return Nothing when (isJust callback && direction arg /= DirectionIn) $ notImplementedError "Only callbacks with DirectionIn are supported" case direction arg of DirectionIn -> if arg `elem` omitted then return . escapedArgName $ arg else case callback of Just c -> if callableThrows (cbCallable c) -- See [Note: Callables that throw] then return (escapedArgName arg) else prepareInCallback arg c expose Nothing -> prepareInArg arg DirectionInout -> prepareInoutArg arg DirectionOut -> prepareOutArg arg prepareInArg :: Arg -> ExcCodeGen Text prepareInArg arg = do let name = escapedArgName arg wrapMaybe arg >>= bool (convert name $ hToF (argType arg) (transfer arg)) (do let maybeName = "maybe" <> ucFirst name nullPtr <- nullPtrForType (argType arg) >>= \case Nothing -> terror $ "Unexpected non-pointer type " <> tshow (argType arg) Just null -> pure null 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 -> Callback -> ExposeClosures -> CodeGen e Text prepareInCallback arg callback@(Callback {cbCallable = cb}) expose = do let name = escapedArgName arg ptrName = "ptr" <> name scope = argScope arg (maker, wrapper, drop) <- case argType arg of TInterface tn -> do let Name _ n = normalizedAPIName (APICallback callback) tn drop <- if callableHasClosures cb && expose == WithoutClosures then Just <$> qualifiedSymbol (callbackDropClosures n) tn else return Nothing wrapper <- qualifiedSymbol (callbackHaskellToForeign n) tn maker <- qualifiedSymbol (callbackWrapperAllocator n) tn return (maker, wrapper, drop) _ -> terror $ "prepareInCallback : Not an interface! " <> T.pack (ppShow arg) wrapMaybe arg >>= bool (do let name' = prime name dropped = case drop of Just dropper -> parenthesize (dropper <> " " <> name) Nothing -> name -- ScopeTypeAsync callbacks are somewhat tricky: they -- will be called only once, and the data associated to -- them will be invalid after the first call. -- -- So we pass them a pointer to a dynamically allocated -- `Ptr FunPtr`, which contains a pointer to the -- `FunPtr` we dynamically allocate wrapping the Haskell -- function. On first invocation, the wrapper will then -- free this memory. p <- if (scope == ScopeTypeAsync) then do ft <- typeShow <$> foreignType (argType arg) line $ ptrName <> " <- callocMem :: IO (Ptr (" <> ft <> "))" return $ parenthesize $ "Just " <> ptrName else return "Nothing" line $ name' <> " <- " <> maker <> " " <> parenthesize (wrapper <> " " <> p <> " " <> dropped) 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 FP.nullFunPtr" let jName = "j" <> ucFirst name jName' = prime jName line $ "Just " <> jName <> " -> do" indent $ do let dropped = case drop of Just dropper -> parenthesize (dropper <> " " <> jName) Nothing -> jName p <- if (scope == ScopeTypeAsync) then do ft <- typeShow <$> foreignType (argType arg) line $ ptrName <> " <- callocMem :: IO (Ptr (" <> ft <> "))" return $ parenthesize $ "Just " <> ptrName else return "Nothing" line $ jName' <> " <- " <> maker <> " " <> parenthesize (wrapper <> " " <> p <> " " <> dropped) when (scope == ScopeTypeAsync) $ line $ "poke " <> ptrName <> " " <> jName' line $ "return " <> jName' return maybeName) prepareInoutArg :: Arg -> ExcCodeGen Text prepareInoutArg arg = do name' <- prepareInArg arg ft <- foreignType $ argType arg allocInfo <- typeAllocInfo (argType arg) case allocInfo of Just (TypeAlloc allocator n) -> do wrapMaybe arg >>= bool (do name'' <- genConversion (prime name') $ literal $ M $ allocator <> " :: " <> typeShow (io ft) line $ "memcpy " <> name'' <> " " <> name' <> " " <> tshow n return name'') -- The semantics of this case are somewhat undefined. (notImplementedError "Nullable inout structs not supported") Nothing -> do if argCallerAllocates arg then return name' else do name'' <- genConversion (prime name') $ literal $ M $ "allocMem :: " <> typeShow (io $ ptr ft) line $ "poke " <> name'' <> " " <> name' return name'' prepareOutArg :: Arg -> ExcCodeGen Text prepareOutArg arg = do let name = escapedArgName arg ft <- foreignType $ argType arg if argCallerAllocates arg then do allocInfo <- typeAllocInfo (argType arg) case allocInfo of Just (TypeAlloc allocator _) -> do genConversion name $ literal $ M $ allocator <> " :: " <> typeShow (io ft) Nothing -> notImplementedError $ ("Don't know how to allocate \"" <> argCName arg <> "\" of type " <> tshow (argType arg)) else do -- Initialize pointers to NULL to avoid a crash in case the function -- does not initialize it. isPtr <- typeIsPtr (argType arg) let alloc = if isPtr then "callocMem" else "allocMem" genConversion name $ literal $ M $ alloc <> " :: " <> typeShow (io $ ptr ft) -- Convert a non-zero terminated out array, stored in a variable -- named "aname", into the corresponding Haskell object. convertOutCArray :: Callable -> Type -> Text -> Map.Map Text Text -> Transfer -> (Text -> Text) -> ExcCodeGen Text convertOutCArray callable t@(TCArray False fixed length _) aname nameMap transfer primeLength = do if fixed > -1 then do unpacked <- convert aname $ unpackCArray (tshow 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 = escapedArgName $ (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'' = primeLength 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 _ _ _ _ = terror $ "convertOutCArray : unexpected " <> tshow t -- Read the array lengths for out arguments. readOutArrayLengths :: Callable -> Map.Map Text Text -> ExcCodeGen () readOutArrayLengths callable nameMap = do let lNames = nub $ map escapedArgName $ 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 = escapedArgName 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" <> T.pack (ppShow arg) <> "\n" <> T.pack (ppShow callable) Nothing -> go as $ Map.insert c arg m -- user_data style arguments. prepareClosures :: Callable -> Map.Map Text Text -> 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! " <> "\nClosure: " <> tshow closure <> "\nc2cm: " <> T.pack (ppShow m) <> "\ncallable: " <> T.pack (ppShow callable) Just cb -> do let closureName = escapedArgName $ (args callable)!!closure n = escapedArgName cb n' <- case Map.lookup n nameMap of Just n -> return n Nothing -> badIntroError $ "Cannot find closure name!! " <> T.pack (ppShow callable) <> "\n" <> T.pack (ppShow nameMap) -- Check that the given closure is an actual callback type. maybeAPI <- findAPI (argType cb) case maybeAPI of Just (APICallback _) -> do case argScope cb of ScopeTypeInvalid -> badIntroError $ "Invalid scope! " <> T.pack (ppShow callable) ScopeTypeNotified -> do line $ "let " <> closureName <> " = castFunPtrToPtr " <> n' case argDestroy cb of (-1) -> badIntroError $ "ScopeTypeNotified without destructor! " <> T.pack (ppShow callable) k -> do let destroyArg = (args callable)!!k destroyName = escapedArgName destroyArg destroyFun <- case argType destroyArg of TInterface (Name "GLib" "DestroyNotify") -> return "SP.safeFreeFunPtrPtr" TInterface (Name "GObject" "ClosureNotify") -> return "SP.safeFreeFunPtrPtr'" _ -> notImplementedError $ "Unknown destroy type: " <> tshow (argType destroyArg) line $ "let " <> destroyName <> " = " <> destroyFun ScopeTypeAsync -> do line $ "let " <> closureName <> " = nullPtr" case argDestroy cb of -- Async callbacks don't really need destroy -- notifications, as they can always be released -- at the end of the callback. (-1) -> return () n -> let destroyName = escapedArgName $ (args callable)!!n in line $ "let " <> destroyName <> " = FP.nullFunPtr" ScopeTypeCall -> line $ "let " <> closureName <> " = nullPtr" ScopeTypeForever -> line $ "let " <> closureName <> " = nullPtr" _ -> badIntroError $ "Closure \"" <> n <> "\" is not a callback." freeCallCallbacks :: Callable -> Map.Map Text Text -> ExcCodeGen () freeCallCallbacks callable nameMap = forM_ (args callable) $ \arg -> do let name = escapedArgName arg name' <- case Map.lookup name nameMap of Just n -> return n Nothing -> badIntroError $ "Could not find " <> name <> " in " <> T.pack (ppShow callable) <> "\n" <> T.pack (ppShow nameMap) when (argScope arg == ScopeTypeCall) $ do isCallback <- typeIsCallback (argType arg) if isCallback then line $ "safeFreeFunPtr $ castFunPtrToPtr " <> name' else comment $ "XXX: Ignoring scope annotation on a non-callback argument: " <> name -- | Format the signature of the Haskell binding for the `Callable`. formatHSignature :: Callable -> ForeignSymbol -> ExposeClosures -> ExcCodeGen () formatHSignature callable symbol expose = do sig <- callableSignature callable symbol expose indent $ do let constraints = "B.CallStack.HasCallStack" : signatureConstraints sig line $ "(" <> T.intercalate ", " constraints <> ") =>" forM_ (zip ("" : repeat "-> ") (signatureArgTypes sig)) $ \(prefix, (maybeArg, t)) -> do line $ prefix <> t case maybeArg of Nothing -> return () Just arg -> writeArgDocumentation arg let resultPrefix = if null (signatureArgTypes sig) then "" else "-> " line $ resultPrefix <> signatureReturnType sig writeReturnDocumentation (signatureCallable sig) (skipRetVal callable) -- | Name for the first argument in dynamic wrappers (the `FunPtr`). funPtr :: Text funPtr = "__funPtr" -- | Signature for a callable. data Signature = Signature { signatureCallable :: Callable , signatureConstraints :: [Text] , signatureArgTypes :: [(Maybe Arg, Text)] , signatureReturnType :: Text } -- | The Haskell signature for the given callable. It returns a tuple -- ([constraints], [(type, argname)]). callableSignature :: Callable -> ForeignSymbol -> ExposeClosures -> ExcCodeGen Signature callableSignature callable symbol expose = do let (hInArgs, _) = callableHInArgs callable (case symbol of KnownForeignSymbol _ -> WithoutClosures DynamicForeignSymbol _ -> WithClosures) (argConstraints, types) <- inArgInterfaces hInArgs expose let constraints = ("MonadIO m" : argConstraints) outType <- hOutType callable (callableHOutArgs callable) return $ Signature { signatureCallable = callable, signatureConstraints = constraints, signatureReturnType = typeShow ("m" `con` [outType]), signatureArgTypes = case symbol of KnownForeignSymbol _ -> zip (map Just hInArgs) types DynamicForeignSymbol w -> zip (Nothing : map Just hInArgs) ("FunPtr " <> dynamicType w : types) } -- | "In" arguments for the given callable on the Haskell side, -- together with the omitted arguments. callableHInArgs :: Callable -> ExposeClosures -> ([Arg], [Arg]) callableHInArgs callable expose = let 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 callbackUserData = filter argCallbackUserData (args callable) omitted = case expose of WithoutClosures -> arrayLengths callable <> closures <> destroyers <> callbackUserData WithClosures -> arrayLengths callable in (filter (`notElem` omitted) inArgs, omitted) -- | "Out" arguments for the given callable on the Haskell side. callableHOutArgs :: Callable -> [Arg] callableHOutArgs callable = let outArgs = filter ((/= DirectionIn) . direction) $ args callable in filter (`notElem` (arrayLengths callable)) outArgs -- | Convert the result of the foreign call to Haskell. convertResult :: Name -> Callable -> Map.Map Text Text -> ExcCodeGen Text convertResult n callable nameMap = if skipRetVal callable || returnType callable == Nothing then return (error "convertResult: unreachable code reached, bug!") else do nullableReturnType <- maybe (return False) typeIsNullable (returnType callable) if returnMayBeNull callable && nullableReturnType then do line $ "maybeResult <- convertIfNonNull result $ \\result' -> do" indent $ do converted <- unwrappedConvertResult "result'" line $ "return " <> converted return "maybeResult" else do when nullableReturnType $ line $ "checkUnexpectedReturnNULL \"" <> lowerName n <> "\" result" unwrappedConvertResult "result" where unwrappedConvertResult rname = case returnType callable of -- Arrays without length information cannot be converted -- into Haskell values. Just (t@(TCArray False (-1) (-1) _)) -> badIntroError ("`" <> tshow t <> "' is an array type, but contains no length information,\n" <> "so it cannot be unpacked.") -- Not zero-terminated C arrays require knowledge of the -- length, so we deal with them directly. Just (t@(TCArray False _ _ _)) -> convertOutCArray callable t rname nameMap (returnTransfer callable) prime Just t -> do result <- convert rname $ fToH t (returnTransfer callable) freeContainerType (returnTransfer callable) t rname undefined return result Nothing -> return (error "unwrappedConvertResult: bug!") -- | Marshal a foreign out argument to Haskell, returning the name of -- the variable containing the converted Haskell value. convertOutArg :: Callable -> Map.Map Text Text -> Arg -> ExcCodeGen Text convertOutArg callable nameMap arg = do let name = escapedArgName arg inName <- case Map.lookup name nameMap of Just name' -> return name' Nothing -> badIntroError $ "Parameter " <> name <> " not found!" case argType arg of t@(TCArray False (-1) (-1) _) -> if argCallerAllocates arg then return inName else badIntroError ("`" <> tshow t <> "' is an array type, but contains no length information,\n" <> "so it cannot be unpacked.") t@(TCArray False _ _ _) -> do aname' <- if argCallerAllocates arg then return inName else genConversion inName $ apply $ M "peek" let arrayLength = if argCallerAllocates arg then id else prime wrapArray a = convertOutCArray callable t a nameMap (transfer arg) arrayLength 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 peeked <- if argCallerAllocates arg 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 argCallerAllocates arg 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 -- | Convert the list of out arguments to Haskell, returning the -- names of the corresponding variables containing the marshaled values. convertOutArgs :: Callable -> Map.Map Text Text -> [Arg] -> ExcCodeGen [Text] convertOutArgs callable nameMap hOutArgs = forM hOutArgs (convertOutArg callable nameMap) -- | Invoke the given C function, taking care of errors. invokeCFunction :: Callable -> ForeignSymbol -> [Text] -> CodeGen e () invokeCFunction callable symbol argNames = do let returnBind = case returnType callable of Nothing -> "" _ -> if skipRetVal callable then "_ <- " else "result <- " maybeCatchGErrors = if callableThrows callable then "propagateGError $ " else "" call = case symbol of KnownForeignSymbol s -> s DynamicForeignSymbol w -> parenthesize (dynamicWrapper w <> " " <> funPtr) line $ returnBind <> maybeCatchGErrors <> call <> (T.concat . map (" " <>)) argNames -- | Return the result of the call, possibly including out arguments. returnResult :: Callable -> Text -> [Text] -> CodeGen e () returnResult callable result pps = if skipRetVal callable || returnType callable == Nothing then case pps of [] -> line "return ()" (pp:[]) -> line $ "return " <> pp _ -> line $ "return (" <> T.intercalate ", " pps <> ")" else case pps of [] -> line $ "return " <> result _ -> line $ "return (" <> T.intercalate ", " (result : pps) <> ")" -- | Generate a Haskell wrapper for the given foreign function. genHaskellWrapper :: Name -> ForeignSymbol -> Callable -> ExposeClosures -> ExcCodeGen Text genHaskellWrapper n symbol callable expose = group $ do let name = case symbol of KnownForeignSymbol _ -> lowerName n DynamicForeignSymbol _ -> callbackDynamicWrapper (upperName n) (hInArgs, omitted) = callableHInArgs callable expose hOutArgs = callableHOutArgs callable line $ name <> " ::" formatHSignature callable symbol expose let argNames = case symbol of KnownForeignSymbol _ -> map escapedArgName hInArgs DynamicForeignSymbol _ -> funPtr : map escapedArgName hInArgs line $ name <> " " <> T.intercalate " " argNames <> " = liftIO $ do" indent (genWrapperBody n symbol callable hInArgs hOutArgs omitted expose) return name -- | Generate the body of the Haskell wrapper for the given foreign symbol. genWrapperBody :: Name -> ForeignSymbol -> Callable -> [Arg] -> [Arg] -> [Arg] -> ExposeClosures -> ExcCodeGen () genWrapperBody n symbol callable hInArgs hOutArgs omitted expose = do readInArrayLengths n callable hInArgs inArgNames <- forM (args callable) $ \arg -> prepareArgForCall omitted arg expose -- Map from argument names to names passed to the C function let nameMap = Map.fromList $ flip zip inArgNames $ map escapedArgName $ args callable prepareClosures callable nameMap if callableThrows callable then do line "onException (do" indent $ do invokeCFunction callable symbol inArgNames readOutArrayLengths callable nameMap result <- convertResult n callable nameMap pps <- convertOutArgs callable nameMap hOutArgs freeCallCallbacks callable nameMap forM_ (args callable) touchInArg mapM_ line =<< freeInArgs callable nameMap returnResult callable 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 callable symbol inArgNames readOutArrayLengths callable nameMap result <- convertResult n callable nameMap pps <- convertOutArgs callable nameMap hOutArgs freeCallCallbacks callable nameMap forM_ (args callable) touchInArg mapM_ line =<< freeInArgs callable nameMap returnResult callable result pps -- | caller-allocates arguments are arguments that the caller -- allocates, and the called function modifies. They are marked as -- 'out' argumens in the introspection data, we sometimes treat them -- as 'inout' arguments instead. The semantics are somewhat tricky: -- for memory management purposes they should be treated as "in" -- arguments, but from the point of view of the exposed API they -- should be treated as "out" or "inout". Unfortunately we cannot -- always just assume that they are purely "out", so in many cases the -- generated API is somewhat suboptimal (since the initial values are -- not important): for example for g_io_channel_read_chars the size of -- the buffer to read is determined by the caller-allocates -- argument. As a compromise, we assume that we can allocate anything -- that is not a TCArray of length determined by an argument. fixupCallerAllocates :: Callable -> Callable fixupCallerAllocates c = c{args = map (fixupLength . fixupDir) (args c)} where fixupDir :: Arg -> Arg fixupDir a = case argType a of TCArray _ _ l _ -> if argCallerAllocates a && l > -1 then a { direction = DirectionInout , transfer = TransferEverything } else a _ -> a lengthsMap :: Map.Map Arg Arg lengthsMap = Map.fromList (map swap (arrayLengthsMap c)) -- Length arguments of caller-allocates arguments should be -- treated as "in". fixupLength :: Arg -> Arg fixupLength a = case Map.lookup a lengthsMap of Nothing -> a Just array -> if argCallerAllocates array then a {direction = DirectionIn} else a -- | The foreign symbol to wrap. It is either a foreign symbol wrapped -- in a foreign import, in which case we are given the name of the -- Haskell wrapper, or alternatively the information about a "dynamic" -- wrapper in scope. data ForeignSymbol = KnownForeignSymbol Text -- ^ Haskell symbol in scope. | DynamicForeignSymbol DynamicWrapper -- ^ Info about the dynamic wrapper. -- | Information about a dynamic wrapper. data DynamicWrapper = DynamicWrapper { dynamicWrapper :: Text -- ^ Haskell dynamic wrapper , dynamicType :: Text -- ^ Name of the type synonym for the -- type of the function to be wrapped. } -- | Some debug info for the callable. genCallableDebugInfo :: Callable -> CodeGen e () genCallableDebugInfo callable = group $ do commentShow "Args" (args callable) commentShow "Lengths" (arrayLengths callable) commentShow "returnType" (returnType callable) line $ "-- throws : " <> (tshow $ callableThrows callable) line $ "-- Skip return : " <> (tshow $ skipReturn callable) when (skipReturn callable && returnType callable /= Just (TBasicType TBoolean)) $ do line "-- XXX return value ignored, but it is not a boolean." line "-- This may be a memory leak?" where commentShow :: Show a => Text -> a -> CodeGen e () commentShow prefix s = let padding = T.replicate (T.length prefix + 2) " " padded = case T.lines (T.pack $ ppShow s) of [] -> [] (f:rest) -> "-- " <> prefix <> ": " <> f : map (("-- " <> padding) <>) rest in mapM_ line padded -- | Generate a wrapper for a known C symbol. genCCallableWrapper :: Name -> Text -> Callable -> ExcCodeGen () genCCallableWrapper n cSymbol callable | callableResolvable callable == Nothing = -- If we reach this point there is some internal error. terror ("Resolvability of “" <> cSymbol <> "” unkown.") | callableResolvable callable == Just False = badIntroError ("Could not resolve the symbol “" <> cSymbol <> "” in the “" <> namespace n <> "” namespace, ignoring.") | otherwise = do genCallableDebugInfo callable let callable' = fixupCallerAllocates callable hSymbol <- mkForeignImport cSymbol callable' blank deprecatedPragma (lowerName n) (callableDeprecated callable) writeDocumentation DocBeforeSymbol (callableDocumentation callable) void (genHaskellWrapper n (KnownForeignSymbol hSymbol) callable' WithoutClosures) -- | For callbacks we do not need to keep track of which arguments are -- closures. forgetClosures :: Callable -> Callable forgetClosures c = c {args = map forgetClosure (args c)} where forgetClosure :: Arg -> Arg forgetClosure arg = arg {argClosure = -1, argCallbackUserData = False} -- | Generate a wrapper for a dynamic C symbol (i.e. a Haskell -- function that will invoke its first argument, which should be a -- `FunPtr` of the appropriate type). The caller should have created a -- type synonym with the right type for the foreign symbol. genDynamicCallableWrapper :: Name -> Text -> Callable -> ExcCodeGen Text genDynamicCallableWrapper n typeSynonym callable = do genCallableDebugInfo callable let callable' = forgetClosures (fixupCallerAllocates callable) wrapper <- mkDynamicImport typeSynonym blank writeHaddock DocBeforeSymbol dynamicDoc let dyn = DynamicWrapper { dynamicWrapper = wrapper , dynamicType = typeSynonym } genHaskellWrapper n (DynamicForeignSymbol dyn) callable' WithClosures where dynamicDoc :: Text dynamicDoc = "Given a pointer to a foreign C function, wrap it into a function callable from Haskell." haskell-gi-0.26.12/lib/Data/GI/CodeGen/Code.hs0000644000000000000000000012776407346545000016544 0ustar0000000000000000{-# LANGUAGE GeneralizedNewtypeDeriving #-} module Data.GI.CodeGen.Code ( Code , ModuleInfo(moduleCode, sectionDocs) , ModuleFlag(..) , CodeGen , ExcCodeGen , CGError , genCode , evalCodeGen , writeModuleTree , listModuleTree , codeToText , transitiveModuleDeps , minBaseVersion , BaseVersion(..) , showBaseVersion , registerNSDependency , qualified , getDeps , recurseWithAPIs , handleCGExc , printCGError , notImplementedError , badIntroError , missingInfoError , indent , increaseIndent , bline , line , blank , group , comment , cppIf , CPPGuard(..) , hsBoot , submodule , setLanguagePragmas , addLanguagePragma , setGHCOptions , setModuleFlags , setModuleMinBase , getFreshTypeVariable , resetTypeVariableScope , exportModule , exportDecl , export , HaddockSection(..) , NamedSection(..) , addSectionFormattedDocs , prependSectionFormattedDocs , findAPI , getAPI , findAPIByName , getAPIs , getC2HMap , config , currentModule ) where #if !MIN_VERSION_base(4,8,0) import Control.Applicative ((<$>)) import Data.Monoid (Monoid(..)) #endif #if MIN_VERSION_base(4,18,0) import Control.Monad (forM, unless, when) #endif import Control.Monad.Reader import Control.Monad.State.Strict import Control.Monad.Except import qualified Data.Foldable as F import Data.Maybe (fromMaybe, catMaybes, mapMaybe) #if !MIN_VERSION_base(4,13,0) import Data.Monoid ((<>), mempty) #endif import qualified Data.Map.Strict as M import Data.Sequence (ViewL ((:<)), viewl, (|>)) import qualified Data.Sequence as Seq import qualified Data.Semigroup as Sem import qualified Data.Set as Set import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Lazy.Builder as B import qualified Data.Text.Lazy as LT import GHC.Stack (HasCallStack) import System.Directory (createDirectoryIfMissing) import System.FilePath (joinPath, takeDirectory) import Data.GI.CodeGen.API (API, Name(..)) import Data.GI.CodeGen.Config (Config(..)) import {-# SOURCE #-} Data.GI.CodeGen.CtoHaskellMap (cToHaskellMap, Hyperlink) import Data.GI.CodeGen.GtkDoc (CRef) import Data.GI.CodeGen.ModulePath (ModulePath(..), dotModulePath, (/.)) import Data.GI.CodeGen.Type (Type(..)) import Data.GI.CodeGen.Util (tshow, terror, padTo, utf8WriteFile) import Data.GI.CodeGen.ProjectInfo (authors, license, maintainers) -- | Set of CPP conditionals understood by the code generator. data CPPConditional = CPPIf Text -- ^ #if Foo deriving (Eq, Show, Ord) -- | The generated `Code` is a sequence of `CodeToken`s. newtype Code = Code (Seq.Seq CodeToken) deriving (Sem.Semigroup, Monoid, Eq, Show, Ord) -- | Initializes a code block to the empty sequence. emptyCode :: Code emptyCode = Code Seq.empty -- | Checks whether the given code block is empty. isCodeEmpty :: Code -> Bool isCodeEmpty (Code seq) = Seq.null seq -- | A block of code consisting of a single token. codeSingleton :: CodeToken -> Code codeSingleton t = Code (Seq.singleton t) -- | Possible code tokens. data CodeToken = Line Text -- ^ A single line, indented to current indentation. | Indent Code -- ^ Indented region. | Group Code -- ^ A grouped set of lines | Comment [Text] -- ^ A (possibly multi line) comment | IncreaseIndent -- ^ Increase the indentation for the rest -- of the lines in the group. | CPPBlock CPPConditional Code -- ^ A block of code guarded by the -- given CPP conditional deriving (Eq, Ord, Show) type Deps = Set.Set Text -- | Subsection of the haddock documentation where the export should -- be located, or alternatively the toplevel section. data HaddockSection = ToplevelSection | Section NamedSection | NamedSubsection NamedSection Text deriving (Show, Eq, Ord) -- | Known subsections. The ordering here is the ordering in which -- they will appear in the haddocks. data NamedSection = MethodSection | PropertySection | SignalSection | EnumSection | FlagSection deriving (Show, Eq, Ord) -- | Symbol to export. type SymbolName = Text -- | Possible exports for a given module. Every export type -- constructor has two parameters: the section of the haddocks where -- it should appear, and the symbol name to export in the export list -- of the module. data Export = Export { exportType :: ExportType -- ^ Which kind of export. , exportSymbol :: SymbolName -- ^ Actual symbol to export. , exportGuards :: [CPPConditional] -- ^ Protect the export by the -- given CPP export guards. } deriving (Show, Eq, Ord) -- | Possible types of exports. data ExportType = ExportSymbol HaddockSection -- ^ An export in the -- given haddock section. | ExportTypeDecl -- ^ A type declaration. | ExportModule -- ^ Reexport of a whole module. deriving (Show, Eq, Ord) -- | Information on a generated module. data ModuleInfo = ModuleInfo { modulePath :: ModulePath -- ^ Full module name: ["Gtk", "Label"]. , moduleCode :: Code -- ^ Generated code for the module. , bootCode :: Code -- ^ Interfaces going into the .hs-boot file. , submodules :: M.Map Text ModuleInfo -- ^ Indexed by the relative -- module name. , moduleDeps :: Deps -- ^ Set of dependencies for this module. , moduleExports :: Seq.Seq Export -- ^ Exports for the module. , qualifiedImports :: Set.Set ModulePath -- ^ Qualified (source) imports. , modulePragmas :: Set.Set Text -- ^ Set of language pragmas for the module. , moduleGHCOpts :: Set.Set Text -- ^ GHC options for compiling the module. , moduleFlags :: Set.Set ModuleFlag -- ^ Flags for the module. , sectionDocs :: M.Map HaddockSection Text -- ^ Documentation -- for the different sections in -- the module. , moduleMinBase :: BaseVersion -- ^ Minimal version of base the -- module will work on. } -- | Flags for module code generation. data ModuleFlag = ImplicitPrelude -- ^ Use the standard prelude, -- instead of the haskell-gi-base short one. deriving (Show, Eq, Ord) -- | Minimal version of base supported by a given module. data BaseVersion = Base47 -- ^ 4.7.0 | Base48 -- ^ 4.8.0 deriving (Show, Eq, Ord) -- | A `Text` representation of the given base version bound. showBaseVersion :: BaseVersion -> Text showBaseVersion Base47 = "4.7" showBaseVersion Base48 = "4.8" -- | Generate the empty module. emptyModule :: ModulePath -> ModuleInfo emptyModule m = ModuleInfo { modulePath = m , moduleCode = emptyCode , bootCode = emptyCode , submodules = M.empty , moduleDeps = Set.empty , moduleExports = Seq.empty , qualifiedImports = Set.empty , modulePragmas = Set.empty , moduleGHCOpts = Set.empty , moduleFlags = Set.empty , sectionDocs = M.empty , moduleMinBase = Base47 } -- | Information for the code generator. data CodeGenConfig = CodeGenConfig { hConfig :: Config -- ^ Ambient config. , loadedAPIs :: M.Map Name API -- ^ APIs available to the generator. , c2hMap :: M.Map CRef Hyperlink -- ^ Map from C references -- to Haskell symbols. } -- | Set of errors for the code generator. data CGError = CGErrorNotImplemented Text | CGErrorBadIntrospectionInfo Text | CGErrorMissingInfo Text deriving (Show) -- | Temporaty state for the code generator. data CGState = CGState { cgsCPPConditionals :: [CPPConditional] -- ^ Active CPP conditionals, -- outermost condition first. , cgsNextAvailableTyvar :: NamedTyvar -- ^ Next unused type -- variable. } -- | The name for a type variable. data NamedTyvar = SingleCharTyvar Char -- ^ A single variable type variable: 'a', 'b', etc... | IndexedTyvar Text Integer -- ^ An indexed type variable: 'a17', 'key1', ... -- | Clean slate for `CGState`. emptyCGState :: CGState emptyCGState = CGState { cgsCPPConditionals = [] , cgsNextAvailableTyvar = SingleCharTyvar 'a' } -- | The base type for the code generator monad. Generators that -- cannot throw errors are parametric in the exception type 'excType'. type CodeGen excType a = ReaderT CodeGenConfig (StateT (CGState, ModuleInfo) (Except excType)) a -- | Code generators that can throw errors. type ExcCodeGen a = CodeGen CGError a -- | Run a `CodeGen` with given `Config` and initial state, returning -- either the resulting exception, or the result and final module info. runCodeGen :: CodeGen e a -> CodeGenConfig -> (CGState, ModuleInfo) -> (Either e (a, ModuleInfo)) runCodeGen cg cfg state = dropCGState <$> runExcept (runStateT (runReaderT cg cfg) state) where dropCGState :: (a, (CGState, ModuleInfo)) -> (a, ModuleInfo) dropCGState (x, (_, m)) = (x, m) -- | This is useful when we plan run a subgenerator, and `mconcat` the -- result to the original structure later. cleanInfo :: ModuleInfo -> ModuleInfo cleanInfo info = info { moduleCode = emptyCode, submodules = M.empty, bootCode = emptyCode, moduleExports = Seq.empty, qualifiedImports = Set.empty, sectionDocs = M.empty, moduleMinBase = Base47 } -- | Run the given code generator using the state and config of an -- ambient CodeGen, but without adding the generated code to -- `moduleCode`, instead returning it explicitly. recurseCG :: CodeGen e a -> CodeGen e (a, Code) recurseCG = recurseWithState id -- | Like `recurseCG`, but we allow for explicitly setting the state -- of the inner code generator. recurseWithState :: (CGState -> CGState) -> CodeGen e a -> CodeGen e (a, Code) recurseWithState cgsSet cg = do cfg <- ask (cgs, oldInfo) <- get -- Start the subgenerator with no code and no submodules. let info = cleanInfo oldInfo case runCodeGen cg cfg (cgsSet cgs, info) of Left e -> throwError e Right (r, new) -> put (cgs, mergeInfoState oldInfo new) >> return (r, moduleCode new) -- | Like `recurseCG`, giving explicitly the set of loaded APIs and C to -- Haskell map for the subgenerator. recurseWithAPIs :: M.Map Name API -> CodeGen e () -> CodeGen e () recurseWithAPIs apis cg = do cfg <- ask (cgs, oldInfo) <- get -- Start the subgenerator with no code and no submodules. let info = cleanInfo oldInfo cfg' = cfg {loadedAPIs = apis, c2hMap = cToHaskellMap (M.toList apis)} case runCodeGen cg cfg' (cgs, info) of Left e -> throwError e Right (_, new) -> put (cgs, mergeInfo oldInfo new) -- | Merge everything but the generated code for the two given `ModuleInfo`. mergeInfoState :: ModuleInfo -> ModuleInfo -> ModuleInfo mergeInfoState oldState newState = let newDeps = Set.union (moduleDeps oldState) (moduleDeps newState) newSubmodules = M.unionWith mergeInfo (submodules oldState) (submodules newState) newExports = moduleExports oldState <> moduleExports newState newImports = qualifiedImports oldState <> qualifiedImports newState newPragmas = Set.union (modulePragmas oldState) (modulePragmas newState) newGHCOpts = Set.union (moduleGHCOpts oldState) (moduleGHCOpts newState) newFlags = Set.union (moduleFlags oldState) (moduleFlags newState) newBoot = bootCode oldState <> bootCode newState newDocs = sectionDocs oldState <> sectionDocs newState newMinBase = max (moduleMinBase oldState) (moduleMinBase newState) in oldState {moduleDeps = newDeps, submodules = newSubmodules, moduleExports = newExports, qualifiedImports = newImports, modulePragmas = newPragmas, moduleGHCOpts = newGHCOpts, moduleFlags = newFlags, bootCode = newBoot, sectionDocs = newDocs, moduleMinBase = newMinBase } -- | Merge the infos, including code too. mergeInfo :: ModuleInfo -> ModuleInfo -> ModuleInfo mergeInfo oldInfo newInfo = let info = mergeInfoState oldInfo newInfo in info { moduleCode = moduleCode oldInfo <> moduleCode newInfo } -- | Add the given submodule to the list of submodules of the current -- module. addSubmodule :: Text -> ModuleInfo -> (CGState, ModuleInfo) -> (CGState, ModuleInfo) addSubmodule modName submodule (cgs, current) = (cgs, current { submodules = M.insertWith mergeInfo modName submodule (submodules current)}) -- | Run the given CodeGen in order to generate a single submodule of the -- current module. Note that we do not generate the submodule if the -- code generator generated no code and the module does not have -- submodules. submodule' :: Text -> CodeGen e () -> CodeGen e () submodule' modName cg = do cfg <- ask (_, oldInfo) <- get let info = emptyModule (modulePath oldInfo /. modName) case runCodeGen cg cfg (emptyCGState, info) of Left e -> throwError e Right (_, smInfo) -> if isCodeEmpty (moduleCode smInfo) && M.null (submodules smInfo) then return () else modify' (addSubmodule modName smInfo) -- | Run the given CodeGen in order to generate a submodule (specified -- an an ordered list) of the current module. submodule :: ModulePath -> CodeGen e () -> CodeGen e () submodule (ModulePath []) cg = cg submodule (ModulePath (m:ms)) cg = submodule' m (submodule (ModulePath ms) cg) -- | Try running the given `action`, and if it fails run `fallback` -- instead. handleCGExc :: (CGError -> CodeGen e a) -> ExcCodeGen a -> CodeGen e a handleCGExc fallback action = do cfg <- ask (cgs, oldInfo) <- get let info = cleanInfo oldInfo case runCodeGen action cfg (cgs, info) of Left e -> fallback e Right (r, newInfo) -> do put (cgs, mergeInfo oldInfo newInfo) return r -- | Return the currently loaded set of dependencies. getDeps :: CodeGen e Deps getDeps = moduleDeps . snd <$> get -- | Return the ambient configuration for the code generator. config :: CodeGen e Config config = hConfig <$> ask -- | Return the name of the current module. currentModule :: CodeGen e Text currentModule = do (_, s) <- get return (dotWithPrefix (modulePath s)) -- | Return the list of APIs available to the generator. getAPIs :: CodeGen e (M.Map Name API) getAPIs = loadedAPIs <$> ask -- | Return the C -> Haskell available to the generator. getC2HMap :: CodeGen e (M.Map CRef Hyperlink) getC2HMap = c2hMap <$> ask -- | Due to the `forall` in the definition of `CodeGen`, if we want to -- run the monad transformer stack until we get a result, our only -- option is ignoring the possible error code from `runExcept`. 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 :: CodeGen e a -> CodeGenConfig -> (CGState, ModuleInfo) -> (a, ModuleInfo) unwrapCodeGen cg cfg info = case runCodeGen cg cfg info of Left _ -> error "unwrapCodeGen:: The impossible happened!" Right (r, newInfo) -> (r, newInfo) -- | Run a code generator, and return the information for the -- generated module together with the return value of the generator. evalCodeGen :: Config -> M.Map Name API -> ModulePath -> CodeGen e a -> (a, ModuleInfo) evalCodeGen cfg apis mPath cg = let initialInfo = emptyModule mPath cfg' = CodeGenConfig {hConfig = cfg, loadedAPIs = apis, c2hMap = cToHaskellMap (M.toList apis)} in unwrapCodeGen cg cfg' (emptyCGState, initialInfo) -- | Like `evalCodeGen`, but discard the resulting output value. genCode :: Config -> M.Map Name API -> ModulePath -> CodeGen e () -> ModuleInfo genCode cfg apis mPath cg = snd $ evalCodeGen cfg apis mPath cg -- | Mark the given dependency as used by the module. registerNSDependency :: Text -> CodeGen e () registerNSDependency name = do deps <- getDeps unless (Set.member name deps) $ do let newDeps = Set.insert name deps modify' $ \(cgs, s) -> (cgs, s {moduleDeps = newDeps}) -- | Return the transitive set of dependencies, i.e. the union of -- those of the module and (transitively) its submodules. transitiveModuleDeps :: ModuleInfo -> Deps transitiveModuleDeps minfo = Set.unions (moduleDeps minfo : map transitiveModuleDeps (M.elems $ submodules minfo)) -- | Given a module name and a symbol in the module (including a -- proper namespace), return a qualified name for the symbol. qualified :: ModulePath -> Name -> CodeGen e Text qualified mp (Name ns s) = do cfg <- config -- Make sure the module is listed as a dependency. when (modName cfg /= ns) $ registerNSDependency ns (_, minfo) <- get if mp == modulePath minfo then return s else do qm <- qualifiedImport mp return (qm <> "." <> s) -- | Import the given module name qualified (as a source import if the -- namespace is the same as the current one), and return the name -- under which the module was imported. qualifiedImport :: ModulePath -> CodeGen e Text qualifiedImport mp = do modify' $ \(cgs, s) -> (cgs, s {qualifiedImports = Set.insert mp (qualifiedImports s)}) return (qualifiedModuleName mp) -- | Construct a simplified version of the module name, suitable for a -- qualified import. qualifiedModuleName :: ModulePath -> Text qualifiedModuleName (ModulePath [ns, "Objects", o]) = ns <> "." <> o qualifiedModuleName (ModulePath [ns, "Interfaces", i]) = ns <> "." <> i qualifiedModuleName (ModulePath [ns, "Structs", s]) = ns <> "." <> s qualifiedModuleName (ModulePath [ns, "Unions", u]) = ns <> "." <> u qualifiedModuleName mp = dotModulePath mp -- | Return the minimal base version supported by the module and all -- its submodules. minBaseVersion :: ModuleInfo -> BaseVersion minBaseVersion minfo = maximum (moduleMinBase minfo : map minBaseVersion (M.elems $ submodules minfo)) -- | Print, as a comment, a friendly textual description of the error. printCGError :: CGError -> CodeGen e () printCGError (CGErrorNotImplemented e) = do comment $ "Not implemented: " <> e printCGError (CGErrorBadIntrospectionInfo e) = comment $ "Bad introspection data: " <> e printCGError (CGErrorMissingInfo e) = comment $ "Missing info: " <> e notImplementedError :: Text -> ExcCodeGen a notImplementedError s = throwError $ CGErrorNotImplemented s badIntroError :: Text -> ExcCodeGen a badIntroError s = throwError $ CGErrorBadIntrospectionInfo s missingInfoError :: Text -> ExcCodeGen a missingInfoError s = throwError $ CGErrorMissingInfo s -- | Get a type variable unused in the current scope. getFreshTypeVariable :: CodeGen e Text getFreshTypeVariable = do (cgs@(CGState{cgsNextAvailableTyvar = available}), s) <- get let (tyvar, next) = case available of SingleCharTyvar char -> case char of 'z' -> ("z", IndexedTyvar "a" 0) -- 'm' is reserved for the MonadIO constraint in signatures 'm' -> ("n", SingleCharTyvar 'o') c -> (T.singleton c, SingleCharTyvar (toEnum $ fromEnum c + 1)) IndexedTyvar root index -> (root <> tshow index, IndexedTyvar root (index+1)) put (cgs {cgsNextAvailableTyvar = next}, s) return tyvar -- | Introduce a new scope for type variable naming: the next fresh -- variable will be called 'a'. resetTypeVariableScope :: CodeGen e () resetTypeVariableScope = modify' (\(cgs, s) -> (cgs {cgsNextAvailableTyvar = SingleCharTyvar 'a'}, s)) -- | Try to find the API associated with a given type, if known. findAPI :: HasCallStack => Type -> CodeGen e (Maybe API) findAPI (TInterface n) = Just <$> findAPIByName n findAPI _ = return Nothing -- | Find the API associated with a given type. If the API cannot be -- found this raises an `error`. getAPI :: HasCallStack => Type -> CodeGen e API getAPI t = findAPI t >>= \case Just a -> return a Nothing -> terror ("Could not resolve type \"" <> tshow t <> "\".") findAPIByName :: HasCallStack => Name -> CodeGen e API findAPIByName n@(Name ns _) = do apis <- getAPIs case M.lookup n apis of Just api -> return api Nothing -> terror $ "couldn't find API description for " <> ns <> "." <> name n -- | Add some code to the current generator. tellCode :: CodeToken -> CodeGen e () tellCode c = modify' (\(cgs, s) -> (cgs, s {moduleCode = moduleCode s <> codeSingleton c})) -- | Print out a (newline-terminated) line. line :: Text -> CodeGen e () line = tellCode . Line -- | Print out the given line both to the normal module, and to the -- HsBoot file. bline :: Text -> CodeGen e () bline l = hsBoot (line l) >> line l -- | A blank line blank :: CodeGen e () blank = line "" -- | A (possibly multi line) comment, separated by newlines comment :: Text -> CodeGen e () comment = tellCode . Comment . T.lines -- | Increase the indent level for code generation. indent :: CodeGen e a -> CodeGen e a indent cg = do (x, code) <- recurseCG cg tellCode (Indent code) return x -- | Increase the indentation level for the rest of the lines in the -- current group. increaseIndent :: CodeGen e () increaseIndent = tellCode IncreaseIndent -- | Group a set of related code. group :: CodeGen e a -> CodeGen e a group cg = do (x, code) <- recurseCG cg tellCode (Group code) blank return x -- | Guard a block of code with @#if@. cppIfBlock :: Text -> CodeGen e a -> CodeGen e a cppIfBlock cond cg = do (x, code) <- recurseWithState addConditional cg tellCode (CPPBlock (CPPIf cond) code) blank return x where addConditional :: CGState -> CGState addConditional cgs = cgs {cgsCPPConditionals = CPPIf cond : cgsCPPConditionals cgs} -- | Possible features to test via CPP. data CPPGuard = CPPOverloading -- ^ Enable overloading | CPPMinVersion Text (Integer, Integer, Integer) -- ^ Require a specific version of the given package. -- | Guard a code block with CPP code, such that it is included only -- if the specified feature is enabled. cppIf :: CPPGuard -> CodeGen e a -> CodeGen e a cppIf CPPOverloading = cppIfBlock "defined(ENABLE_OVERLOADING)" cppIf (CPPMinVersion pkg (a,b,c)) = cppIfBlock $ "MIN_VERSION_" <> pkg <> "(" <> tshow a <> "," <> tshow b <> "," <> tshow c <> ")" -- | Write the given code into the .hs-boot file for the current module. hsBoot :: CodeGen e a -> CodeGen e a hsBoot cg = do (x, code) <- recurseCG cg modify' (\(cgs, s) -> (cgs, s{bootCode = bootCode s <> addGuards (cgsCPPConditionals cgs) code})) return x where addGuards :: [CPPConditional] -> Code -> Code addGuards [] c = c addGuards (cond : conds) c = codeSingleton $ CPPBlock cond (addGuards conds c) -- | Add a export to the current module. exportPartial :: ([CPPConditional] -> Export) -> CodeGen e () exportPartial partial = modify' $ \(cgs, s) -> (cgs, let e = partial $ cgsCPPConditionals cgs in s{moduleExports = moduleExports s |> e}) -- | Reexport a whole module. exportModule :: SymbolName -> CodeGen e () exportModule m = exportPartial (Export ExportModule m) -- | Add a type declaration-related export. exportDecl :: SymbolName -> CodeGen e () exportDecl d = exportPartial (Export ExportTypeDecl d) -- | Export a symbol in the given haddock subsection. export :: HaddockSection -> SymbolName -> CodeGen e () export s n = exportPartial (Export (ExportSymbol s) n) -- | Set the language pragmas for the current module. setLanguagePragmas :: [Text] -> CodeGen e () setLanguagePragmas ps = modify' $ \(cgs, s) -> (cgs, s{modulePragmas = Set.fromList ps}) -- | Add a language pragma for the current module. addLanguagePragma :: Text -> CodeGen e () addLanguagePragma p = modify' $ \(cgs, s) -> (cgs, s{modulePragmas = Set.insert p (modulePragmas s)}) -- | Set the GHC options for compiling this module (in a OPTIONS_GHC pragma). setGHCOptions :: [Text] -> CodeGen e () setGHCOptions opts = modify' $ \(cgs, s) -> (cgs, s{moduleGHCOpts = Set.fromList opts}) -- | Set the given flags for the module. setModuleFlags :: [ModuleFlag] -> CodeGen e () setModuleFlags flags = modify' $ \(cgs, s) -> (cgs, s{moduleFlags = Set.fromList flags}) -- | Set the minimum base version supported by the current module. setModuleMinBase :: BaseVersion -> CodeGen e () setModuleMinBase v = modify' $ \(cgs, s) -> (cgs, s{moduleMinBase = max v (moduleMinBase s)}) -- | Add documentation for a given section. addSectionFormattedDocs :: HaddockSection -> Text -> CodeGen e () addSectionFormattedDocs section docs = modify' $ \(cgs, s) -> (cgs, s{sectionDocs = M.insertWith (flip (<>)) section docs (sectionDocs s)}) -- | Prepend documentation at the beginning of a given section. prependSectionFormattedDocs :: HaddockSection -> Text -> CodeGen e () prependSectionFormattedDocs section docs = modify' $ \(cgs, s) -> (cgs, s{sectionDocs = M.insertWith (<>) section docs (sectionDocs s)}) -- | Format a CPP conditional. cppCondFormat :: CPPConditional -> (Text, Text) cppCondFormat (CPPIf c) = ("#if " <> c <> "\n", "#endif\n") -- | Return a text representation of the `Code`. codeToText :: Code -> Text codeToText (Code seq) = LT.toStrict . B.toLazyText $ genCode 0 (viewl seq) where genCode :: Int -> ViewL CodeToken -> B.Builder genCode _ Seq.EmptyL = mempty genCode n (Line s :< rest) = B.fromText (paddedLine n s) <> genCode n (viewl rest) genCode n (Indent (Code seq) :< rest) = genCode (n+1) (viewl seq) <> genCode n (viewl rest) genCode n (Group (Code seq) :< rest) = genCode n (viewl seq) <> genCode n (viewl rest) genCode n (Comment [] :< rest) = genCode n (viewl rest) genCode n (Comment [s] :< rest) = B.fromText (paddedLine n ("-- " <> s)) <> genCode n (viewl rest) genCode n (Comment (l:ls):< rest) = B.fromText ("{- " <> l <> "\n" <> paddedLines (n+1) ls <> "-}\n") <> genCode n (viewl rest) genCode n (CPPBlock cond (Code seq) :< rest) = let (condBegin, condEnd) = cppCondFormat cond in B.fromText condBegin <> genCode n (viewl seq) <> B.fromText condEnd <> genCode n (viewl rest) genCode n (IncreaseIndent :< rest) = genCode (n+1) (viewl rest) -- | Pad a line to the given number of leading tabs (with one tab -- equal to four spaces), and add a newline at the end. paddedLine :: Int -> Text -> Text paddedLine n s = T.replicate (n * 4) " " <> s <> "\n" -- | Pad a set of lines to the given number of leading tabs (with one -- tab equal to four spaces), and add a newline at the end of each -- line. paddedLines :: Int -> [Text] -> Text paddedLines n ls = mconcat $ map (paddedLine n) ls -- | Put a (padded) comma at the end of the text. comma :: Text -> Text comma s = padTo 40 s <> "," -- | Format the given export symbol. formatExport :: (Export -> Text) -> Export -> Text formatExport formatName export = go (exportGuards export) where go :: [CPPConditional] -> Text go [] = (paddedLine 1 . comma . formatName) export go (c:cs) = let (begin, end) = cppCondFormat c in begin <> go cs <> end -- | Format the list of exported modules. formatExportedModules :: [Export] -> Maybe Text formatExportedModules [] = Nothing formatExportedModules exports = Just . T.concat . map (formatExport (("module " <>) . exportSymbol)) . filter ((== ExportModule) . exportType) $ exports -- | Format the toplevel exported symbols. formatToplevel :: [Export] -> Maybe Text formatToplevel [] = Nothing formatToplevel exports = Just . T.concat . map (formatExport exportSymbol) . filter ((== ExportSymbol ToplevelSection) . exportType) $ exports -- | Format the type declarations section. formatTypeDecls :: [Export] -> Maybe Text formatTypeDecls exports = let exportedTypes = filter ((== ExportTypeDecl) . exportType) exports in if exportedTypes == [] then Nothing else Just . T.unlines $ [ "-- * Exported types" , T.concat . map ( formatExport exportSymbol ) $ exportedTypes ] -- | A subsection name, with an optional anchor name. data Subsection = Subsection { subsectionTitle :: Text , subsectionAnchor :: Maybe Text , subsectionDoc :: Maybe Text } deriving (Eq, Show, Ord) -- | A subsection with an anchor given by the title and @prefix:title@ -- anchor, and the given documentation. subsecWithPrefix :: NamedSection -> Text -> Maybe Text -> Subsection subsecWithPrefix mainSection title doc = Subsection { subsectionTitle = title , subsectionAnchor = Just (prefix <> ":" <> title) , subsectionDoc = doc } where prefix = case mainSection of MethodSection -> "method" PropertySection -> "attr" SignalSection -> "signal" EnumSection -> "enum" FlagSection -> "flag" -- | User-facing name in the Haddocks for the given main section. mainSectionName :: NamedSection -> Text mainSectionName MethodSection = "Methods" mainSectionName PropertySection = "Properties" mainSectionName SignalSection = "Signals" mainSectionName EnumSection = "Enumerations" mainSectionName FlagSection = "Flags" -- | Format a given section made of subsections. formatSection :: M.Map HaddockSection Text -> NamedSection -> (Set.Set Export, [(Subsection, Export)]) -> Maybe Text formatSection docs section (sectionExports, subsectionExports) = if null subsectionExports && Set.null sectionExports then Nothing else let docstring = case M.lookup (Section section) docs of Nothing -> "" Just s -> formatHaddockComment s in Just . T.unlines $ [" -- * " <> mainSectionName section , docstring , ( T.concat . map (formatExport exportSymbol) . Set.toList ) sectionExports , ( T.unlines . map formatSubsection . M.toList ) exportedSubsections] where exportedSubsections :: M.Map Subsection (Set.Set Export) exportedSubsections = foldr extract M.empty subsectionExports extract :: (Subsection, Export) -> M.Map Subsection (Set.Set Export) -> M.Map Subsection (Set.Set Export) extract (subsec, m) secs = M.insertWith Set.union subsec (Set.singleton m) secs formatSubsection :: (Subsection, Set.Set Export) -> Text formatSubsection (subsec, symbols) = T.unlines [ "-- ** " <> case subsectionAnchor subsec of Just anchor -> subsectionTitle subsec <> " #" <> anchor <> "#" Nothing -> subsectionTitle subsec , case subsectionDoc subsec of Just text -> formatHaddockComment text Nothing -> "" , ( T.concat . map (formatExport exportSymbol) . Set.toList ) symbols] -- | Format the list of exports into grouped sections. formatSubsectionExports :: M.Map HaddockSection Text -> [Export] -> [Maybe Text] formatSubsectionExports docs exports = map (uncurry (formatSection docs)) (M.toAscList collectedExports) where collectedExports :: M.Map NamedSection (Set.Set Export, [(Subsection, Export)]) collectedExports = foldl classifyExport M.empty exports classifyExport :: M.Map NamedSection (Set.Set Export, [(Subsection, Export)]) -> Export -> M.Map NamedSection (Set.Set Export, [(Subsection, Export)]) classifyExport m export = let join (snew, exnew) (sold, exold) = (Set.union snew sold, exnew ++ exold) in case exportType export of ExportSymbol hs@(NamedSubsection ms n) -> let subsec = subsecWithPrefix ms n (M.lookup hs docs) in M.insertWith join ms (Set.empty, [(subsec, export)]) m ExportSymbol (Section s) -> M.insertWith join s (Set.singleton export, []) m _ -> m -- | Format the given export list. This is just the inside of the -- parenthesis. formatExportList :: M.Map HaddockSection Text -> [Export] -> Text formatExportList docs exports = T.unlines . catMaybes $ formatExportedModules exports : formatToplevel exports : formatTypeDecls exports : formatSubsectionExports docs exports -- | Write down the list of language pragmas. languagePragmas :: [Text] -> Text languagePragmas [] = "" languagePragmas ps = "{-# LANGUAGE " <> T.intercalate ", " ps <> " #-}\n" -- | Write down the list of GHC options. ghcOptions :: [Text] -> Text ghcOptions [] = "" ghcOptions opts = "{-# OPTIONS_GHC " <> T.intercalate ", " opts <> " #-}\n" -- | Generate some convenience CPP macros. cppMacros :: Text cppMacros = T.unlines ["#if (MIN_VERSION_haskell_gi_overloading(1,0,0) && !defined(__HADDOCK_VERSION__))" , "#define ENABLE_OVERLOADING" , "#endif"] -- | Standard fields for every module. standardFields :: Text standardFields = T.unlines [ "Copyright : " <> authors , "License : " <> license , "Maintainer : " <> maintainers ] -- | The haddock header for the module, including optionally a description. moduleHaddock :: Maybe Text -> Text moduleHaddock Nothing = formatHaddockComment $ standardFields moduleHaddock (Just description) = formatHaddockComment $ T.unlines [standardFields, description] -- | Format the comment with the module documentation. formatHaddockComment :: Text -> Text formatHaddockComment doc = let lines = case T.lines doc of [] -> [] (first:rest) -> ("-- | " <> first) : map ("-- " <>) rest in T.unlines lines -- | Generic module prelude. We reexport all of the submodules. modulePrelude :: M.Map HaddockSection Text -> Text -> [Export] -> [Text] -> Text modulePrelude _ name [] [] = "module " <> name <> " () where\n" modulePrelude docs name exports [] = "module " <> name <> "\n ( " <> formatExportList docs exports <> " ) where\n" modulePrelude docs name [] reexportedModules = "module " <> name <> "\n ( " <> formatExportList docs (map (\m -> Export ExportModule m []) reexportedModules) <> " ) where\n\n" <> T.unlines (map ("import " <>) reexportedModules) modulePrelude docs name exports reexportedModules = "module " <> name <> "\n ( " <> formatExportList docs (map (\m -> Export ExportModule m []) reexportedModules) <> "\n" <> formatExportList docs exports <> " ) where\n\n" <> T.unlines (map ("import " <>) reexportedModules) -- | Code for loading the needed dependencies. One needs to give the -- prefix for the namespace being currently generated, modules with -- this prefix will be imported as {-# SOURCE #-}, and otherwise will -- be imported normally. importDeps :: ModulePath -> [ModulePath] -> Text importDeps (ModulePath prefix) deps = T.unlines . map toImport $ deps where toImport :: ModulePath -> Text toImport dep = let impSt = if importSource dep then "import {-# SOURCE #-} qualified " else "import qualified " in impSt <> dotWithPrefix dep <> " as " <> qualifiedModuleName dep importSource :: ModulePath -> Bool importSource (ModulePath [_, "Callbacks"]) = False importSource (ModulePath mp) = take (length prefix) mp == prefix -- | Standard imports. moduleImports :: Text moduleImports = T.unlines [ "import Data.GI.Base.ShortPrelude" , "import qualified Data.GI.Base.ShortPrelude as SP" , "import qualified Data.GI.Base.Overloading as O" , "import qualified Prelude as P" , "" , "import qualified Data.GI.Base.Attributes as GI.Attributes" , "import qualified Data.GI.Base.BasicTypes as B.Types" , "import qualified Data.GI.Base.ManagedPtr as B.ManagedPtr" , "import qualified Data.GI.Base.GArray as B.GArray" , "import qualified Data.GI.Base.GClosure as B.GClosure" , "import qualified Data.GI.Base.GError as B.GError" , "import qualified Data.GI.Base.GHashTable as B.GHT" , "import qualified Data.GI.Base.GVariant as B.GVariant" , "import qualified Data.GI.Base.GValue as B.GValue" , "import qualified Data.GI.Base.GParamSpec as B.GParamSpec" , "import qualified Data.GI.Base.CallStack as B.CallStack" , "import qualified Data.GI.Base.Properties as B.Properties" , "import qualified Data.GI.Base.Signals as B.Signals" , "import qualified Control.Monad.IO.Class as MIO" , "import qualified Data.Coerce as Coerce" , "import qualified Data.Text as T" , "import qualified Data.Kind as DK" , "import qualified Data.ByteString.Char8 as B" , "import qualified Data.Map as Map" , "import qualified Foreign.Ptr as FP" , "import qualified GHC.OverloadedLabels as OL" , "import qualified GHC.Records as R" , "import qualified Data.Word as DW" , "import qualified Data.Int as DI" , "import qualified System.Posix.Types as SPT" , "import qualified Foreign.C.Types as FCT"] -- | Like `dotModulePath`, but add a "GI." prefix. dotWithPrefix :: ModulePath -> Text dotWithPrefix mp = dotModulePath ("GI" <> mp) -- | Write to disk the code for a module, under the given base -- directory. Does not write submodules recursively, for that use -- `writeModuleTree`. writeModuleInfo :: Bool -> Maybe FilePath -> ModuleInfo -> M.Map ModulePath ModuleInfo -> IO () writeModuleInfo verbose dirPrefix minfo treeMap = do let submodulePaths = map (modulePath) (M.elems (submodules minfo)) -- We reexport any submodules. submoduleExports = map dotWithPrefix submodulePaths fname = modulePathToFilePath dirPrefix (modulePath minfo) ".hs" dirname = takeDirectory fname code = codeToText (moduleCode minfo) pragmas = languagePragmas (Set.toList $ modulePragmas minfo) optionsGHC = ghcOptions (Set.toList $ moduleGHCOpts minfo) prelude = modulePrelude (sectionDocs minfo) (dotWithPrefix $ modulePath minfo) (F.toList (moduleExports minfo)) submoduleExports imports = if ImplicitPrelude `Set.member` moduleFlags minfo then "" else moduleImports pkgRoot = ModulePath (take 1 (modulePathToList $ modulePath minfo)) allImports = transitiveImports minfo treeMap minimalImports = qualifiedImports minfo allDeps = importDeps pkgRoot (Set.toList allImports) minimalDeps = importDeps pkgRoot (Set.toList minimalImports) deps = T.unlines [ "-- Workaround for https://gitlab.haskell.org/ghc/ghc/-/issues/23392", "#if MIN_VERSION_base(4,18,0)", allDeps, "#else", minimalDeps, "#endif" ] haddock = moduleHaddock (M.lookup ToplevelSection (sectionDocs minfo)) when verbose $ putStrLn ((T.unpack . dotWithPrefix . modulePath) minfo ++ " -> " ++ fname) createDirectoryIfMissing True dirname utf8WriteFile fname (T.unlines [pragmas, optionsGHC, haddock, cppMacros, prelude, imports, deps, code]) when (not . isCodeEmpty $ bootCode minfo) $ do let bootFName = modulePathToFilePath dirPrefix (modulePath minfo) ".hs-boot" utf8WriteFile bootFName (genHsBoot minfo) -- | Collect the transitive set of imports for this module. In -- principle just importing the set of strictly necessary imports (via -- qualifiedImports) should be sufficient; the following is a -- workaround for a GHC bug: -- https://gitlab.haskell.org/ghc/ghc/-/issues/23392 transitiveImports :: ModuleInfo -> M.Map ModulePath ModuleInfo -> Set.Set ModulePath transitiveImports root treeMap = collectImports root Set.empty where collectImports :: ModuleInfo -> Set.Set ModulePath -> Set.Set ModulePath collectImports minfo deps = let isCallbacks (ModulePath [_, "Callbacks"]) = True isCallbacks _ = False -- Deps that we haven't analysed yet. unseenDeps = Set.filter (\e -> Set.notMember e deps) (qualifiedImports minfo) -- Make sure we don't try to import ourselves unrooted = Set.filter (\mp -> mp /= modulePath root) unseenDeps unseenModules = mapMaybe (\d -> M.lookup d treeMap) (Set.toList unrooted) -- We don't collect implicit deps from the callbacks module, -- which is always imported normally (not just the hs-boot) notCallbacks = filter (not . isCallbacks . modulePath) unseenModules -- Imports in unseenDeps depImports = map (\m -> collectImports m (Set.union deps unseenDeps)) notCallbacks in Set.unions (unrooted : depImports) -- | Generate the .hs-boot file for the given module. genHsBoot :: ModuleInfo -> Text genHsBoot minfo = cppMacros <> "module " <> (dotWithPrefix . modulePath) minfo <> " where\n\n" <> moduleImports <> "\n" <> codeToText (bootCode minfo) -- | Construct the filename corresponding to the given module. modulePathToFilePath :: Maybe FilePath -> ModulePath -> FilePath -> FilePath modulePathToFilePath dirPrefix (ModulePath mp) ext = joinPath (fromMaybe "" dirPrefix : "GI" : map T.unpack mp) ++ ext -- | Write down the code for a module and its submodules to disk under -- the given base directory. It returns the list of written modules. writeModuleTree :: Bool -> Maybe FilePath -> ModuleInfo -> IO [Text] writeModuleTree verbose dirPrefix root = doWriteModuleTree root where doWriteModuleTree :: ModuleInfo -> IO [Text] doWriteModuleTree minfo = do submodulePaths <- concat <$> forM (M.elems (submodules minfo)) doWriteModuleTree writeModuleInfo verbose dirPrefix minfo treeMap return $ (dotWithPrefix (modulePath minfo) : submodulePaths) treeMap = M.fromList (gatherSubmodules root) gatherSubmodules :: ModuleInfo -> [(ModulePath, ModuleInfo)] gatherSubmodules minfo = (modulePath minfo, minfo) : concatMap gatherSubmodules (M.elems $ submodules minfo) -- | Return the list of modules `writeModuleTree` would write, without -- actually writing anything to disk. listModuleTree :: ModuleInfo -> [Text] listModuleTree minfo = let submodulePaths = concatMap listModuleTree (M.elems (submodules minfo)) in dotWithPrefix (modulePath minfo) : submodulePaths haskell-gi-0.26.12/lib/Data/GI/CodeGen/CodeGen.hs0000644000000000000000000005366607346545000017175 0ustar0000000000000000module Data.GI.CodeGen.CodeGen ( genConstant , genFunction , genModule ) where import Control.Monad (forM, forM_, when, unless, filterM) import Data.List (nub) import Data.Maybe (fromJust, fromMaybe, catMaybes, mapMaybe) #if !MIN_VERSION_base(4,13,0) import Data.Monoid ((<>)) #endif import qualified Data.Map as M import qualified Data.Text as T import Data.Text (Text) import Data.GI.CodeGen.API import Data.GI.CodeGen.Callable (genCCallableWrapper) import Data.GI.CodeGen.Constant (genConstant) import Data.GI.CodeGen.Code import Data.GI.CodeGen.EnumFlags (genEnum, genFlags) import Data.GI.CodeGen.Fixups (dropMovedItems, guessPropertyNullability, detectGObject, dropDuplicatedFields, checkClosureDestructors, fixSymbolNaming, fixClosures, fixCallbackUserData) import Data.GI.CodeGen.GObject import Data.GI.CodeGen.Haddock (deprecatedPragma, addSectionDocumentation, writeHaddock, RelativeDocPosition(DocBeforeSymbol)) import Data.GI.CodeGen.Inheritance (instanceTree, fullObjectMethodList, fullInterfaceMethodList) import Data.GI.CodeGen.Properties (genInterfaceProperties, genObjectProperties, genNamespacedPropLabels) import Data.GI.CodeGen.OverloadedSignals (genInterfaceSignals, genObjectSignals) import Data.GI.CodeGen.OverloadedMethods (genMethodList, genMethodInfo, genUnsupportedMethodInfo) import Data.GI.CodeGen.Signal (genSignal, genCallback) import Data.GI.CodeGen.Struct (genStructOrUnionFields, extractCallbacksInStruct, fixAPIStructs, ignoreStruct, genZeroStruct, genZeroUnion, genBoxed, genWrappedPtr) import Data.GI.CodeGen.SymbolNaming (upperName, classConstraint, submoduleLocation, lowerName, qualifiedAPI, normalizedAPIName, safeCast) import Data.GI.CodeGen.Type import Data.GI.CodeGen.Util (tshow) genFunction :: Name -> Function -> CodeGen e () genFunction n (Function symbol fnMovedTo callable) = -- Only generate the function if it has not been moved. when (Nothing == fnMovedTo) $ group $ do line $ "-- function " <> name n handleCGExc (\e -> do line ("-- XXX Could not generate function " <> name n <> "\n") printCGError e) (do genCCallableWrapper n symbol callable export (NamedSubsection MethodSection $ lowerName n) (lowerName n) ) -- | Create the newtype wrapping the ManagedPtr for the given type. genNewtype :: Text -> CodeGen e () genNewtype name' = do group $ do bline $ "newtype " <> name' <> " = " <> name' <> " (SP.ManagedPtr " <> name' <> ")" indent $ line $ "deriving (Eq)" group $ do bline $ "instance SP.ManagedPtrNewtype " <> name' <> " where" indent $ line $ "toManagedPtr (" <> name' <> " p) = p" -- | Generate wrapper for structures. genStruct :: Name -> Struct -> CodeGen e () genStruct n s = unless (ignoreStruct n s) $ do let Name _ name' = normalizedAPIName (APIStruct s) n writeHaddock DocBeforeSymbol ("Memory-managed wrapper type.") genNewtype name' exportDecl (name' <> ("(..)")) addSectionDocumentation ToplevelSection (structDocumentation s) if structIsBoxed s then genBoxed n (fromJust $ structTypeInit s) else genWrappedPtr n (structAllocationInfo s) (structSize s) -- Generate a builder for a structure filled with zeroes. genZeroStruct n s -- Generate code for fields. genStructOrUnionFields n (structFields s) -- Methods methods <- forM (structMethods s) $ \f -> do let mn = methodName f isFunction <- symbolFromFunction (methodSymbol f) if not isFunction then handleCGExc (\e -> do line ("-- XXX Could not generate method " <> name' <> "::" <> name mn) printCGError e return Nothing) (genMethod n f >> return (Just (n, f))) else return Nothing -- Overloaded methods cppIf CPPOverloading (genMethodList n (catMaybes methods)) -- | Generated wrapper for unions. genUnion :: Name -> Union -> CodeGen e () genUnion n u = do let Name _ name' = normalizedAPIName (APIUnion u) n writeHaddock DocBeforeSymbol ("Memory-managed wrapper type.") genNewtype name' exportDecl (name' <> "(..)") addSectionDocumentation ToplevelSection (unionDocumentation u) if unionIsBoxed u then genBoxed n (fromJust $ unionTypeInit u) else genWrappedPtr n (unionAllocationInfo u) (unionSize u) -- Generate a builder for a structure filled with zeroes. genZeroUnion n u -- Generate code for fields. genStructOrUnionFields n (unionFields u) -- Methods methods <- forM (unionMethods u) $ \f -> do let mn = methodName f isFunction <- symbolFromFunction (methodSymbol f) if not isFunction then handleCGExc (\e -> do line ("-- XXX Could not generate method " <> name' <> "::" <> name mn) printCGError e return Nothing) (genMethod n f >> return (Just (n, f))) else return Nothing -- Overloaded methods cppIf CPPOverloading $ genMethodList n (catMaybes methods) -- | When parsing the GIR file we add the implicit object argument to -- methods of an object. Since we are prepending an argument we need -- to adjust the offset of the length arguments of CArrays, and -- closure and destroyer offsets. fixMethodArgs :: Callable -> Callable fixMethodArgs c = c { args = args'' , returnType = returnType' } where returnType' = maybe Nothing (Just . fixCArrayLength) (returnType c) args' = map (fixDestroyers . fixClosures . fixLengthArg) (args c) args'' = case args' of inst:rest -> fixInstanceDirection inst : rest [] -> [] fixLengthArg :: Arg -> Arg fixLengthArg arg = arg { argType = fixCArrayLength (argType arg)} fixCArrayLength :: Type -> Type fixCArrayLength (TCArray zt fixed length t) = if length > -1 then TCArray zt fixed (length+1) t else TCArray zt fixed length t fixCArrayLength t = t fixDestroyers :: Arg -> Arg fixDestroyers arg = let destroy = argDestroy arg in if destroy > -1 then arg {argDestroy = destroy + 1} else arg fixClosures :: Arg -> Arg fixClosures arg = let closure = argClosure arg in if closure > -1 then arg {argClosure = closure + 1} else arg -- We always treat the instance argument of a method as "in", -- even if the introspection data says otherwise (this is -- generally an erroneous annotation, meaning that the structure -- is modified). fixInstanceDirection :: Arg -> Arg fixInstanceDirection arg = arg { direction = DirectionIn} -- For constructors we want to return the actual type of the object, -- rather than a generic superclass (so Gtk.labelNew returns a -- Gtk.Label, rather than a Gtk.Widget) fixConstructorReturnType :: Bool -> Name -> Callable -> Callable fixConstructorReturnType returnsGObject cn c = c { returnType = returnType' } where returnType' = if returnsGObject then Just (TInterface cn) else returnType c genMethod :: Name -> Method -> ExcCodeGen () genMethod cn m@(Method { methodName = mn, methodSymbol = sym, methodCallable = c, methodType = t }) = do let name' = upperName cn returnsGObject <- maybe (return False) isGObject (returnType c) line $ "-- method " <> name' <> "::" <> name mn line $ "-- method type : " <> tshow t let -- Mangle the name to namespace it to the class. mn' = mn { name = name cn <> "_" <> name mn } let c' = if Constructor == t then fixConstructorReturnType returnsGObject cn c else c c'' = if OrdinaryMethod == t then fixMethodArgs c' else c' genCCallableWrapper mn' sym c'' export (NamedSubsection MethodSection $ lowerName mn) (lowerName mn') cppIf CPPOverloading $ genMethodInfo cn (m {methodCallable = c''}) -- | Generate an import for the gvalue getter for the given type. It -- returns the name of the function on the Haskell side. genGValueGetter :: Text -> Text -> CodeGen e Text genGValueGetter name' get_value_fn = group $ do let symb = "gv_get_" <> get_value_fn line $ "foreign import ccall \"" <> get_value_fn <> "\" " <> symb <> " ::" indent $ line $ "FP.Ptr B.GValue.GValue -> IO (FP.Ptr " <> name' <> ")" return symb -- | Generate an import for the gvalue setter for the given type. It -- returns the name of the function on the Haskell side. genGValueSetter :: Text -> Text -> CodeGen e Text genGValueSetter name' set_value_fn = group $ do let symb = "gv_set_" <> set_value_fn line $ "foreign import ccall \"" <> set_value_fn <> "\" " <> symb <> " ::" indent $ line $ "FP.Ptr B.GValue.GValue -> FP.Ptr " <> name' <> " -> IO ()" return symb -- | Generate the GValue instances for the given GObject. genGValueInstance :: Name -> Text -> Text -> Text -> Text -> CodeGen e () genGValueInstance n get_type_fn newFn get_value_fn set_value_fn = do let name' = upperName n doc = "Convert '" <> name' <> "' to and from 'Data.GI.Base.GValue.GValue'. See 'Data.GI.Base.GValue.toGValue' and 'Data.GI.Base.GValue.fromGValue'." writeHaddock DocBeforeSymbol doc group $ do bline $ "instance B.GValue.IsGValue (Maybe " <> name' <> ") where" indent $ group $ do line $ "gvalueGType_ = " <> get_type_fn line $ "gvalueSet_ gv P.Nothing = " <> set_value_fn <> " gv (FP.nullPtr :: FP.Ptr " <> name' <> ")" line $ "gvalueSet_ gv (P.Just obj) = B.ManagedPtr.withManagedPtr obj (" <> set_value_fn <> " gv)" line $ "gvalueGet_ gv = do" indent $ group $ do line $ "ptr <- " <> get_value_fn <> " gv :: IO (FP.Ptr " <> name' <> ")" line $ "if ptr /= FP.nullPtr" line $ "then P.Just <$> " <> newFn <> " " <> name' <> " ptr" line $ "else return P.Nothing" -- | Type casting with type checking, returns the function returning the -- GType for the oject. genCasts :: Name -> Text -> [Name] -> CodeGen e Text genCasts n ti parents = do isGO <- isGObject (TInterface n) let name' = upperName n get_type_fn <- do let cn_ = "c_" <> ti group $ do line $ "foreign import ccall \"" <> ti <> "\"" indent $ line $ cn_ <> " :: IO B.Types.GType" return cn_ group $ do bline $ "instance B.Types.TypedObject " <> name' <> " where" indent $ do line $ "glibType = " <> get_type_fn when isGO $ group $ do bline $ "instance B.Types.GObject " <> name' className <- classConstraint n group $ do exportDecl className writeHaddock DocBeforeSymbol (classDoc name') -- Create the IsX constraint. We cannot simply say -- -- > type IsX o = (GObject o, ...) -- -- since we sometimes need to refer to @IsX@ itself, without -- applying it. We instead use the trick of creating a class with -- a universal instance. let constraints = if isGO then "(SP.GObject o, O.IsDescendantOf " <> name' <> " o)" else "(SP.BoxedPtr o, SP.TypedObject o, O.IsDescendantOf " <> name' <> " o)" bline $ "class " <> constraints <> " => " <> className <> " o" bline $ "instance " <> constraints <> " => " <> className <> " o" blank parentAPIs <- mapM (\n -> getAPI (TInterface n)) parents qualifiedParents <- mapM (uncurry qualifiedAPI) (zip parentAPIs parents) bline $ "instance O.HasParentTypes " <> name' line $ "type instance O.ParentTypes " <> name' <> " = '[" <> T.intercalate ", " qualifiedParents <> "]" -- Safe downcasting. group $ do cast <- safeCast n exportDecl cast writeHaddock DocBeforeSymbol (castDoc name') bline $ cast <> " :: (MIO.MonadIO m, " <> className <> " o) => o -> m " <> name' line $ cast <> " = MIO.liftIO . B.ManagedPtr.unsafeCastTo " <> name' return get_type_fn where castDoc :: Text -> Text castDoc name' = "Cast to `" <> name' <> "`, for types for which this is known to be safe. " <> "For general casts, use `Data.GI.Base.ManagedPtr.castTo`." classDoc :: Text -> Text classDoc name' = "Type class for types which can be safely cast to `" <> name' <> "`, for instance with `to" <> name' <> "`." -- | Wrap a given Object. We enforce that every Object that we wrap is a -- GObject. This is the case for everything except the ParamSpec* set -- of objects, we deal with these separately. genObject :: Name -> Object -> CodeGen e () genObject n o = do let Name _ name' = normalizedAPIName (APIObject o) n let t = TInterface n isGO <- isGObject t writeHaddock DocBeforeSymbol ("Memory-managed wrapper type.") genNewtype name' exportDecl (name' <> "(..)") addSectionDocumentation ToplevelSection (objDocumentation o) -- Type safe casting to parent objects, and implemented interfaces. parents <- instanceTree n get_type_fn <- genCasts n (objTypeInit o) (parents <> objInterfaces o) if isGO then genGValueInstance n get_type_fn "B.ManagedPtr.newObject" "B.GValue.get_object" "B.GValue.set_object" else case (objGetValueFunc o, objSetValueFunc o) of (Just get_value_fn, Just set_value_fn) -> do getter <- genGValueGetter name' get_value_fn setter <- genGValueSetter name' set_value_fn genGValueInstance n get_type_fn "B.ManagedPtr.newPtr" getter setter _ -> line $ "--- XXX Missing getter and/or setter, so no GValue instance could be generated." cppIf CPPOverloading $ fullObjectMethodList n o >>= genMethodList n if isGO then do forM_ (objSignals o) $ \s -> genSignal s n genObjectProperties n o cppIf CPPOverloading $ genNamespacedPropLabels n (objProperties o) (objMethods o) cppIf CPPOverloading $ genObjectSignals n o else group $ do let allocInfo = AllocationInfo { allocCalloc = AllocationOpUnknown, allocCopy = case objRefFunc o of Just ref -> AllocationOp ref Nothing -> AllocationOpUnknown, allocFree = case objUnrefFunc o of Just unref -> AllocationOp unref Nothing -> AllocationOpUnknown } genWrappedPtr n allocInfo 0 -- Methods forM_ (objMethods o) $ \f -> do let mn = methodName f handleCGExc (\e -> do line ("-- XXX Could not generate method " <> name' <> "::" <> name mn) printCGError e cppIf CPPOverloading $ genUnsupportedMethodInfo n f) (genMethod n f) genInterface :: Name -> Interface -> CodeGen e () genInterface n iface = do let Name _ name' = normalizedAPIName (APIInterface iface) n line $ "-- interface " <> name' <> " " writeHaddock DocBeforeSymbol ("Memory-managed wrapper type.") deprecatedPragma name' $ ifDeprecated iface genNewtype name' exportDecl (name' <> "(..)") addSectionDocumentation ToplevelSection (ifDocumentation iface) isGO <- apiIsGObject n (APIInterface iface) if isGO then do let cn_ = fromMaybe (error "GObject derived interface without a type!") (ifTypeInit iface) gobjectPrereqs <- filterM nameIsGObject (ifPrerequisites iface) allParents <- forM gobjectPrereqs $ \p -> (p : ) <$> instanceTree p let uniqueParents = nub (concat allParents) get_type_fn <- genCasts n cn_ uniqueParents genGValueInstance n get_type_fn "B.ManagedPtr.newObject" "B.GValue.get_object" "B.GValue.set_object" genInterfaceProperties n iface cppIf CPPOverloading $ genNamespacedPropLabels n (ifProperties iface) (ifMethods iface) else group $ do cls <- classConstraint n exportDecl cls writeHaddock DocBeforeSymbol ("Type class for types which implement `" <> name' <> "`.") -- Create the IsX constraint. We cannot simply say -- -- > type IsX o = (ManagedPtrNewtype o, O.IsDescendantOf X o) -- -- since we sometimes need to refer to @IsX@ itself, without -- applying it. We instead use the trick of creating a class with -- a universal instance. let constraints = "(ManagedPtrNewtype o, O.IsDescendantOf " <> name' <> " o)" bline $ "class " <> constraints <> " => " <> cls <> " o" bline $ "instance " <> constraints <> " => " <> cls <> " o" genWrappedPtr n (ifAllocationInfo iface) 0 when (not . null . ifProperties $ iface) $ group $ do comment $ "XXX Skipping property generation for non-GObject interface" -- Methods cppIf CPPOverloading $ fullInterfaceMethodList n iface >>= genMethodList n forM_ (ifMethods iface) $ \f -> do let mn = methodName f isFunction <- symbolFromFunction (methodSymbol f) unless isFunction $ handleCGExc (\e -> do comment ("XXX Could not generate method " <> name' <> "::" <> name mn) printCGError e cppIf CPPOverloading (genUnsupportedMethodInfo n f)) (genMethod n f) -- Signals forM_ (ifSignals iface) $ \s -> handleCGExc (\e -> do line $ T.concat ["-- XXX Could not generate signal ", name', "::" , sigName s] printCGError e) (genSignal s n) cppIf CPPOverloading $ genInterfaceSignals n iface -- Some type libraries include spurious interface/struct methods, -- where a method Mod.Foo::func also appears as an ordinary function -- in the list of APIs. If we find a matching function (without the -- "moved-to" annotation), we don't generate the method. -- -- It may be more expedient to keep a map of symbol -> function. symbolFromFunction :: Text -> CodeGen e Bool symbolFromFunction sym = do apis <- getAPIs return $ any (hasSymbol sym . snd) $ M.toList apis where hasSymbol sym1 (APIFunction (Function { fnSymbol = sym2, fnMovedTo = movedTo })) = sym1 == sym2 && movedTo == Nothing hasSymbol _ _ = False genAPI :: Name -> API -> CodeGen e () genAPI n (APIConst c) = genConstant n c genAPI n (APIFunction f) = genFunction n f genAPI n (APIEnum e) = genEnum n e genAPI n (APIFlags f) = genFlags n f genAPI n (APICallback c) = genCallback n c genAPI n (APIStruct s) = genStruct n s genAPI n (APIUnion u) = genUnion n u genAPI n (APIObject o) = genObject n o genAPI n (APIInterface i) = genInterface n i -- | Generate the code for a given API in the corresponding module. genAPIModule :: Name -> API -> CodeGen e () genAPIModule n api = submodule (submoduleLocation n api) $ genAPI n api genModule' :: M.Map Name API -> CodeGen e () genModule' apis = do mapM_ (uncurry genAPIModule) -- We provide these ourselves $ filter (not . handWritten) -- Some callback types are defined inside structs $ map fixAPIStructs -- Some APIs contain duplicated fields by mistake, drop -- the duplicates. $ map dropDuplicatedFields $ mapMaybe (traverse dropMovedItems) $ M.toList apis -- Make sure we generate a "Callbacks" module, since it is imported -- by other modules. It is fine if it ends up empty. submodule "Callbacks" (return ()) where -- Whether we provide hand-written bindings for the given API, -- replacing the ones that would be autogenerated from the -- introspection data. handWritten :: (Name, API) -> Bool handWritten (Name "GLib" "Array", _) = True handWritten (Name "GLib" "Error", _) = True handWritten (Name "GLib" "HashTable", _) = True handWritten (Name "GLib" "List", _) = True handWritten (Name "GLib" "SList", _) = True handWritten (Name "GLib" "Variant", _) = True handWritten (Name "GObject" "Value", _) = True handWritten (Name "GObject" "Closure", _) = True handWritten _ = False genModule :: M.Map Name API -> CodeGen e () genModule apis = do -- Reexport Data.GI.Base for convenience (so it does not need to be -- imported separately). line "import Data.GI.Base" exportModule "Data.GI.Base" -- Some API symbols are embedded into structures, extract these and -- inject them into the set of APIs loaded and being generated. let embeddedAPIs = (fixAPIs . M.fromList . concatMap extractCallbacksInStruct . M.toList) apis allAPIs <- getAPIs let contextAPIs = M.union (fixAPIs allAPIs) embeddedAPIs targetAPIs = M.union (fixAPIs apis) embeddedAPIs recurseWithAPIs contextAPIs (genModule' targetAPIs) where fixAPIs :: M.Map Name API -> M.Map Name API fixAPIs apis = M.fromList -- Try to guess nullability of properties when there is no -- nullability info in the GIR. $ map guessPropertyNullability -- Not every interface providing signals or properties is -- correctly annotated as descending from GObject, fix this. $ map detectGObject -- Make sure that every argument marked as being a -- destructor for a user_data argument has an associated -- user_data argument. $ map checkClosureDestructors -- Make sure that the argClosure argument refers to a callback, -- not to the user_data field. $ map fixClosures -- Make sure that the user_data argument of callbacks is -- annotated as such. $ map fixCallbackUserData -- Make sure that the symbols to be generated are valid -- Haskell identifiers, when necessary. $ map fixSymbolNaming $ M.toList apis haskell-gi-0.26.12/lib/Data/GI/CodeGen/Config.hs0000644000000000000000000000145407346545000017062 0ustar0000000000000000-- | Configuration for the code generator. module Data.GI.CodeGen.Config ( Config(..) ) where import Data.Text (Text) import Data.GI.CodeGen.Overrides (Overrides) data Config = Config { -- | GIR name of the module being generated (Gtk, GObject, ...). modName :: Text, -- | Version of the GIR API for the package being generated -- ("3.0", "2.0", ...). modVersion :: Text, -- | Haskell package being generated (gi-gtk, gi-gobject, ...). ghcPkgName :: Text, -- | Version of the haskell package ("3.0.35", "2.0.21", ...). ghcPkgVersion :: Text, -- | Whether to print extra info. verbose :: Bool, -- | List of loaded overrides for the code generator. overrides :: Overrides } deriving Show haskell-gi-0.26.12/lib/Data/GI/CodeGen/Constant.hs0000644000000000000000000001203407346545000017442 0ustar0000000000000000module Data.GI.CodeGen.Constant ( genConstant ) where #if !MIN_VERSION_base(4,11,0) import Data.Monoid ((<>)) #endif import Data.Text (Text) import Data.GI.CodeGen.API import Data.GI.CodeGen.Code import Data.GI.CodeGen.Conversions import Data.GI.CodeGen.Haddock (deprecatedPragma, writeDocumentation, RelativeDocPosition(..)) import Data.GI.CodeGen.Type import Data.GI.CodeGen.Util (tshow, ucFirst) -- | Data for a bidrectional pattern synonym. It is either a simple -- one of the form "pattern Name = value :: Type" or an explicit one -- of the form -- > pattern Name <- (view -> value) :: Type where -- > Name = expression value :: Type data PatternSynonym = SimpleSynonym PSValue PSType | ExplicitSynonym PSView PSExpression PSValue PSType -- Some simple types for legibility type PSValue = Text type PSType = Text type PSView = Text type PSExpression = Text writePattern :: Text -> PatternSynonym -> CodeGen e () writePattern name (SimpleSynonym value t) = line $ "pattern " <> ucFirst name <> " = " <> value <> " :: " <> t writePattern name (ExplicitSynonym view expression value t) = do -- Supported only on ghc >= 7.10 setModuleMinBase Base48 line $ "pattern " <> ucFirst name <> " <- (" <> view <> " -> " <> value <> ") :: " <> t <> " where" indent $ line $ ucFirst name <> " = " <> expression <> " " <> value <> " :: " <> t genConstant :: Name -> Constant -> CodeGen e () genConstant (Name _ name) c = group $ do setLanguagePragmas ["PatternSynonyms", "ScopedTypeVariables", "ViewPatterns"] deprecatedPragma name (constantDeprecated c) handleCGExc (\e -> do line $ "-- XXX: Could not generate constant" printCGError e ) (do writeDocumentation DocBeforeSymbol (constantDocumentation c) assignValue name (constantType c) (constantValue c) export ToplevelSection ("pattern " <> ucFirst name)) -- | Assign to the given name the given constant value, in a way that -- can be assigned to the corresponding Haskell type. assignValue :: Text -> Type -> Text -> ExcCodeGen () assignValue name t@(TBasicType TPtr) value = do ht <- typeShow <$> haskellType t writePattern name (ExplicitSynonym "ptrToIntPtr" "intPtrToPtr" value ht) assignValue name t@(TBasicType b) value = do ht <- typeShow <$> haskellType t hv <- showBasicType b value writePattern name (SimpleSynonym hv ht) assignValue name t@(TInterface _) value = do ht <- typeShow <$> haskellType t api <- findAPI t case api of Just (APIEnum _) -> writePattern name (ExplicitSynonym "fromEnum" "toEnum" value ht) Just (APIFlags _) -> do -- gflagsToWord and wordToGFlags are polymorphic, so in this -- case we need to specialize so the type of the pattern is -- not ambiguous. let wordValue = "(" <> value <> " :: Word64)" writePattern name (ExplicitSynonym "gflagsToWord" "wordToGFlags" wordValue ht) _ -> notImplementedError $ "Don't know how to treat constants of type " <> tshow t assignValue _ t _ = notImplementedError $ "Don't know how to treat constants of type " <> tshow t -- | Show a basic type, in a way that can be assigned to the -- corresponding Haskell type. showBasicType :: BasicType -> Text -> ExcCodeGen Text showBasicType TInt i = return i showBasicType TUInt i = return i showBasicType TLong i = return i showBasicType TULong i = return i showBasicType TInt8 i = return i showBasicType TUInt8 i = return i showBasicType TInt16 i = return i showBasicType TUInt16 i = return i showBasicType TInt32 i = return i showBasicType TUInt32 i = return i showBasicType TInt64 i = return i showBasicType TUInt64 i = return i showBasicType TBoolean "0" = return "P.False" showBasicType TBoolean "false" = return "P.False" showBasicType TBoolean "1" = return "P.True" showBasicType TBoolean "true" = return "P.True" showBasicType TBoolean b = notImplementedError $ "Could not parse boolean \"" <> b <> "\"" showBasicType TFloat f = return f showBasicType TDouble d = return d showBasicType TUTF8 s = return . tshow $ s showBasicType TFileName fn = return . tshow $ fn showBasicType TUniChar c = return $ "'" <> c <> "'" showBasicType TGType gtype = return $ "GType " <> gtype showBasicType TIntPtr ptr = return ptr showBasicType TUIntPtr ptr = return ptr showBasicType TShort s = return s showBasicType TUShort u = return u showBasicType TSSize s = return s showBasicType TSize s = return s showBasicType Ttime_t t = return t showBasicType Toff_t o = return o showBasicType Tdev_t d = return d showBasicType Tgid_t g = return g showBasicType Tpid_t p = return p showBasicType Tsocklen_t l = return l showBasicType Tuid_t u = return u -- We take care of this one separately above showBasicType TPtr _ = notImplementedError $ "Cannot directly show a pointer" haskell-gi-0.26.12/lib/Data/GI/CodeGen/Conversions.hsc0000644000000000000000000012762407346545000020340 0ustar0000000000000000{-# LANGUAGE PatternGuards, DeriveFunctor #-} module Data.GI.CodeGen.Conversions ( convert , genConversion , unpackCArray , computeArrayLength , callableHasClosures , hToF , fToH , transientToH , haskellType , isoHaskellType , foreignType , argumentType , ExposeClosures(..) , elementType , elementMap , elementTypeAndMap , isManaged , typeIsNullable , typeIsPtr , typeIsCallback , maybeNullConvert , nullPtrForType , typeAllocInfo , TypeAllocInfo(..) , apply , mapC , literal , Constructor(..) ) where #include #if !MIN_VERSION_base(4,13,0) import Data.Monoid ((<>)) #endif import Control.Monad (when) import Data.Maybe (isJust) import Data.Text (Text) import qualified Data.Text as T import GHC.Exts (IsString(..)) import Foreign.C.Types (CInt, CUInt) import Foreign.Storable (sizeOf) import Data.GI.CodeGen.API import Data.GI.CodeGen.Code import Data.GI.CodeGen.GObject import Data.GI.CodeGen.SymbolNaming import Data.GI.CodeGen.Type import Data.GI.CodeGen.Util -- | The free monad. data Free f r = Free (f (Free f r)) | Pure r instance Functor f => Functor (Free f) where fmap f = go where go (Pure a) = Pure (f a) go (Free fa) = Free (go <$> fa) instance (Functor f) => Applicative (Free f) where pure = Pure Pure a <*> Pure b = Pure $ a b Pure a <*> Free mb = Free $ fmap a <$> mb Free ma <*> b = Free $ (<*> b) <$> ma instance (Functor f) => Monad (Free f) where (Free x) >>= f = Free (fmap (>>= f) x) (Pure r) >>= f = f r -- | Lift some command to the Free monad. liftF :: (Functor f) => f r -> Free f r liftF command = Free (fmap Pure command) -- 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 Text | M Text | Id deriving (Eq,Show) instance IsString Constructor where fromString = P . T.pack data FExpr next = Apply Constructor next | LambdaConvert Text 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 -> Text mapName Map = "map" mapName MapFirst = "mapFirst" mapName MapSecond = "mapSecond" -- Naming for the monadic versions of the maps that we use monadicMapName :: Map -> Text 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 () lambdaConvert :: Text -> Converter lambdaConvert c = liftF $ LambdaConvert c () genConversion :: Text -> Converter -> CodeGen e Text 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 LambdaConvert conv next -> do line $ conv <> " " <> l <> " $ \\" <> l' <> " -> do" increaseIndent 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 :: Text -> Type -> ExcCodeGen Text computeArrayLength array (TCArray _ _ _ t) = do reader <- findReader return $ "fromIntegral $ " <> reader <> " " <> array where findReader = case t of TBasicType TUInt8 -> return "B.length" _ -> return "P.length" computeArrayLength _ t = notImplementedError $ "computeArrayLength called on non-CArray type " <> tshow t convert :: Text -> CodeGen e Converter -> CodeGen e Text 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 "B.ManagedPtr.disownObject" else return $ M "B.ManagedPtr.disownManagedPtr" -- 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 $ M "unsafeManagedPtrCastPtr" hVariantToF :: Transfer -> CodeGen e Constructor hVariantToF transfer = if transfer == TransferEverything then return $ M "B.GVariant.disownGVariant" else return $ M "unsafeManagedPtrGetPtr" hValueToF :: Transfer -> CodeGen e Constructor hValueToF transfer = if transfer == TransferEverything then return $ M "B.GValue.disownGValue" else return $ M "unsafeManagedPtrGetPtr" hParamSpecToF :: Transfer -> CodeGen e Constructor hParamSpecToF transfer = if transfer == TransferEverything then return $ M "B.GParamSpec.disownGParamSpec" else return $ M "unsafeManagedPtrGetPtr" hClosureToF :: Transfer -> Maybe Type -> CodeGen e Constructor -- Untyped closures hClosureToF transfer Nothing = if transfer == TransferEverything then return $ M "B.GClosure.disownGClosure" -- We cast the point here because the foreign type for untyped -- closures is always represented as Ptr (GClosure ()), while the -- corresponding Haskell type is the parametric "GClosure a". else return $ M "unsafeManagedPtrCastPtr" -- Typed closures hClosureToF transfer (Just _) = if transfer == TransferEverything then return $ M "B.GClosure.disownGClosure" else return $ M "unsafeManagedPtrGetPtr" hBoxedToF :: Transfer -> CodeGen e Constructor hBoxedToF transfer = if transfer == TransferEverything then return $ M "B.ManagedPtr.disownBoxed" else return $ M "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 $ M "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 $ M "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 | TGValue <- t = hValueToF transfer | TParamSpec <- t = hParamSpecToF transfer | TGClosure c <- t = hClosureToF transfer c | 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 TPtr) <- 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 TPtr) <- t = return $ M "packPtrArray" | TCArray False _ _ (TBasicType TUInt8) <- t = return $ M "packByteString" | TCArray False _ _ (TBasicType TBoolean) <- t = return $ M "(packMapStorableArray (P.fromIntegral . P.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 TUniChar) <- t = return $ M "(packMapStorableArray (P.fromIntegral . SP.ord))" | TCArray False _ _ (TBasicType _) <- t = return $ M "packStorableArray" | TCArray False _ _ TGValue <- t = return $ M "B.GValue.packGValueArray" | TCArray{} <- t = notImplementedError $ "Don't know how to pack C array of type " <> tshow t | otherwise = case (typeShow hType, typeShow fType) of ("T.Text", "CString") -> return $ M "textToCString" ("[Char]", "CString") -> return $ M "stringToCString" ("Char", "CInt") -> return "(P.fromIntegral . SP.ord)" ("Bool", "CInt") -> return "(P.fromIntegral . P.fromEnum)" ("Float", "CFloat") -> return "realToFrac" ("Double", "CDouble") -> return "realToFrac" ("GType", "CGType") -> return "gtypeToCGType" _ -> notImplementedError $ "Don't know how to convert " <> typeShow hType <> " into " <> typeShow fType <> ".\n" <> "Internal type: " <> tshow 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 -> Text -> 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 (Text, Text) hashTableKeyMappings (TBasicType TPtr) = return ("gDirectHash", "gDirectEqual") hashTableKeyMappings (TBasicType TUTF8) = return ("gStrHash", "gStrEqual") hashTableKeyMappings t = notImplementedError $ "GHashTable key of type " <> tshow 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 (Text, Text, Text) hashTablePtrPackers (TBasicType TPtr) = return ("Nothing", "B.GHT.ptrPackPtr", "B.GHT.ptrUnpackPtr") hashTablePtrPackers (TBasicType TUTF8) = return ("(Just ptr_to_g_free)", "B.GHT.cstringPackPtr", "B.GHT.cstringUnpackPtr") hashTablePtrPackers TGValue = return ("(Just B.GValue.ptr_to_gvalue_free)", "B.GHT.gvaluePackPtr", "B.GHT.gvalueUnpackPtr") hashTablePtrPackers t = notImplementedError $ "GHashTable element of type " <> tshow 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 (T.intercalate " " ["packGHashTable", keyHash, keyEqual, keyDestroy, elemDestroy])) hToF :: Type -> Transfer -> ExcCodeGen Converter hToF (TGList t) transfer = do isPtr <- typeIsPtr t when (not isPtr) $ badIntroError ("'" <> tshow t <> "' is not a pointer type, cannot pack into a GList.") hToF_PackedType t "packGList" transfer hToF (TGSList t) transfer = do isPtr <- typeIsPtr t when (not isPtr) $ badIntroError ("'" <> tshow t <> "' is not a pointer type, cannot pack into a GSList.") 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 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 <- typeIsEnumOrFlag 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 " <> tshow 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 :: Text -> Transfer -> CodeGen e Constructor boxedForeignPtr constructor transfer = return $ case transfer of TransferEverything -> M $ parenthesize $ "wrapBoxed " <> constructor _ -> M $ parenthesize $ "newBoxed " <> constructor suForeignPtr :: Bool -> TypeRep -> Transfer -> CodeGen e Constructor suForeignPtr isBoxed hType transfer = do let constructor = typeConName hType if isBoxed then boxedForeignPtr constructor transfer else return $ M $ parenthesize $ case transfer of TransferEverything -> "wrapPtr " <> constructor _ -> "newPtr " <> constructor structForeignPtr :: Struct -> TypeRep -> Transfer -> CodeGen e Constructor structForeignPtr s = suForeignPtr (structIsBoxed s) unionForeignPtr :: Union -> TypeRep -> Transfer -> CodeGen e Constructor unionForeignPtr u = suForeignPtr (unionIsBoxed u) fObjectToH :: Type -> TypeRep -> Transfer -> ExcCodeGen Constructor fObjectToH t hType transfer = do let constructor = typeConName hType isGO <- isGObject t return $ M $ parenthesize $ case transfer of TransferEverything -> if isGO then "wrapObject " <> constructor else "wrapPtr " <> constructor _ -> if isGO then "newObject " <> constructor else "newPtr " <> constructor fCallbackToH :: TypeRep -> Transfer -> ExcCodeGen Constructor fCallbackToH hType TransferNothing = do let constructor = typeConName hType return (P (callbackDynamicWrapper constructor)) fCallbackToH _ transfer = notImplementedError ("ForeignCallback with unsupported transfer type `" <> tshow transfer <> "'") fVariantToH :: Transfer -> CodeGen e Constructor fVariantToH transfer = return $ M $ case transfer of TransferEverything -> "B.GVariant.wrapGVariantPtr" _ -> "B.GVariant.newGVariantFromPtr" fValueToH :: Transfer -> CodeGen e Constructor fValueToH transfer = return $ M $ case transfer of TransferEverything -> "B.GValue.wrapGValuePtr" _ -> "B.GValue.newGValueFromPtr" fParamSpecToH :: Transfer -> CodeGen e Constructor fParamSpecToH transfer = return $ M $ case transfer of TransferEverything -> "B.GParamSpec.wrapGParamSpecPtr" _ -> "B.GParamSpec.newGParamSpecFromPtr" fClosureToH :: Transfer -> Maybe Type -> CodeGen e Constructor -- Untyped closures fClosureToH transfer Nothing = return $ M $ case transfer of TransferEverything -> parenthesize $ "B.GClosure.wrapGClosurePtr . FP.castPtr" _ -> parenthesize $ "B.GClosure.newGClosureFromPtr . FP.castPtr" -- Typed closures fClosureToH transfer (Just _) = return $ M $ case transfer of TransferEverything -> "B.GClosure.wrapGClosurePtr" _ -> "B.GClosure.newGClosureFromPtr" 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 | TGValue <- t = fValueToH transfer | TParamSpec <- t = fParamSpecToH transfer | TGClosure c <- t = fClosureToH transfer c | 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 _) <- a = fCallbackToH 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 TPtr) <- 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 " <> tshow t | TByteArray <- t = return $ M "unpackGByteArray" | TGHash _ _ <- t = notImplementedError "Foreign Hashes not supported yet" | otherwise = case (typeShow fType, typeShow 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 " <> typeShow fType <> " into " <> typeShow hType <> ".\n" <> "Internal type: " <> tshow 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 -> Text -> 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 = do isPtr <- typeIsPtr t when (not isPtr) $ badIntroError ("`" <> tshow t <> "' is not a pointer type, cannot unpack from a GList.") fToH_PackedType t "unpackGList" transfer fToH (TGSList t) transfer = do isPtr <- typeIsPtr t when (not isPtr) $ badIntroError ("`" <> tshow t <> "' is not a pointer type, cannot unpack from a GSList.") 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 -- We cannot unpack arrays without any kind of length info. fToH t@(TCArray False (-1) (-1) _) _ = badIntroError ("`" <> tshow t <> "' is an array type, but contains no length information.") fToH (TCArray True _ _ t@(TCArray{})) transfer = fToH_PackedType t "unpackZeroTerminatedPtrArray" transfer fToH (TCArray True _ _ t@(TInterface _)) transfer = do isScalar <- typeIsEnumOrFlag 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 -- | Somewhat like `fToH`, but with slightly different borrowing -- semantics: in the case of `TransferNothing` we wrap incoming -- pointers to boxed structs into transient `ManagedPtr`s (every other -- case behaves as `fToH`). These are `ManagedPtr`s for which we do -- not make a copy, and which will be disowned when the function -- exists, instead of making a copy that the GC will collect -- eventually. -- -- This is necessary in order to get the semantics of callbacks and -- signals right: in some cases making a copy of the object does not -- simply increase the refcount, but rather makes a full copy. In this -- cases modification of the original object is not possible, but this -- is sometimes useful, see for example -- -- https://github.com/haskell-gi/haskell-gi/issues/97 -- -- Another situation where making a copy of incoming arguments is -- problematic is when the underlying library is not thread-safe. When -- running under the threaded GHC runtime it can happen that the GC -- runs on a different OS thread than the thread where the object was -- created, and this leads to rather mysterious bugs, see for example -- -- https://github.com/haskell-gi/haskell-gi/issues/96 -- -- This case is particularly nasty, since it affects `onWidgetDraw`, -- which is very common. transientToH :: Type -> Transfer -> ExcCodeGen Converter transientToH t@(TInterface _) TransferNothing = do a <- findAPI t case a of Just (APIStruct s) -> if structIsBoxed s then wrapTransient else fToH t TransferNothing Just (APIUnion u) -> if unionIsBoxed u then wrapTransient else fToH t TransferNothing _ -> fToH t TransferNothing transientToH t transfer = fToH t transfer -- | Wrap the given transient. wrapTransient :: CodeGen e Converter wrapTransient = return $ lambdaConvert $ "B.ManagedPtr.withTransient " unpackCArray :: Text -> 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 TPtr -> 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 TUniChar -> return $ apply $ M $ parenthesize $ "unpackMapStorableArrayWithLength (SP.chr . P.fromIntegral) " <> length TBasicType _ -> return $ apply $ M $ parenthesize $ "unpackStorableArrayWithLength " <> length TGValue -> return $ apply $ M $ parenthesize $ "B.GValue.unpackGValueArrayWithLength " <> length TInterface _ -> do a <- findAPI t isScalar <- typeIsEnumOrFlag t hType <- haskellType t fType <- foreignType t 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 " <> tshow size | otherwise = "unpackBlockArrayWithLength " <> tshow size -- We always make a copy of the elements when unpacking -- boxed types. let transfer' | boxed = if transfer == TransferContainer then TransferEverything else transfer | otherwise = transfer innerConstructor <- fToH' t a hType fType transfer' return $ do apply $ M $ parenthesize $ unpacker <> " " <> length mapC innerConstructor _ -> notImplementedError $ "unpackCArray : Don't know how to unpack C Array of type " <> tshow t unpackCArray _ _ _ = notImplementedError "unpackCArray : unexpected array type." -- | Whether to expose closures and the associated destroy notify -- handlers in the Haskell wrapper. data ExposeClosures = WithClosures | WithoutClosures deriving (Eq) -- | 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 :: Type -> ExposeClosures -> CodeGen e (Text, [Text]) argumentType (TGList a) expose = do (name, constraints) <- argumentType a expose return ("[" <> name <> "]", constraints) argumentType (TGSList a) expose = do (name, constraints) <- argumentType a expose return ("[" <> name <> "]", constraints) argumentType t expose = do api <- findAPI t s <- typeShow <$> haskellType t case api of -- Instead of restricting to the actual class, -- we allow for any object descending from it. Just (APIInterface _) -> do cls <- typeConstraint t l <- getFreshTypeVariable return (l, [cls <> " " <> l]) Just (APIObject _) -> do cls <- typeConstraint t l <- getFreshTypeVariable return (l, [cls <> " " <> l]) Just (APICallback cb) -> -- See [Note: Callables that throw] if callableThrows (cbCallable cb) then do ft <- typeShow <$> foreignType t return (ft, []) else case expose of WithClosures -> do s_withClosures <- typeShow <$> isoHaskellType t return (s_withClosures, []) WithoutClosures -> return (s, []) _ -> return (s, []) haskellBasicType :: BasicType -> TypeRep haskellBasicType TPtr = ptr $ con0 "()" haskellBasicType TBoolean = con0 "Bool" -- For all the platforms that we support (and those supported by glib) -- we have gint == gint32. Encoding this assumption in the types saves -- conversions. haskellBasicType TInt = case sizeOf (0 :: CInt) of 4 -> con0 "Int32" n -> error ("Unsupported `gint' length: " ++ show n) haskellBasicType TUInt = case sizeOf (0 :: CUInt) of 4 -> con0 "Word32" n -> error ("Unsupported `guint' length: " ++ show n) haskellBasicType TLong = con0 "FCT.CLong" haskellBasicType TULong = con0 "FCT.CULong" haskellBasicType TInt8 = con0 "Int8" haskellBasicType TUInt8 = con0 "Word8" haskellBasicType TInt16 = con0 "Int16" haskellBasicType TUInt16 = con0 "Word16" haskellBasicType TInt32 = con0 "Int32" haskellBasicType TUInt32 = con0 "Word32" haskellBasicType TInt64 = con0 "Int64" haskellBasicType TUInt64 = con0 "Word64" haskellBasicType TGType = con0 "GType" haskellBasicType TUTF8 = con0 "T.Text" haskellBasicType TFloat = con0 "Float" haskellBasicType TDouble = con0 "Double" haskellBasicType TUniChar = con0 "Char" haskellBasicType TFileName = con0 "[Char]" haskellBasicType TIntPtr = con0 "CIntPtr" haskellBasicType TUIntPtr = con0 "CUIntPtr" haskellBasicType TShort = con0 "FCT.CShort" haskellBasicType TUShort = con0 "FCT.CUShort" haskellBasicType TSSize = #if defined(HTYPE_SSIZE_T) con0 "SPT.CSsize" #else int #{size gsize} #endif haskellBasicType TSize = con0 "FCT.CSize" haskellBasicType Ttime_t = con0 "FCT.CTime" haskellBasicType Toff_t = #if defined(HTYPE_OFF_T) con0 "SPT.COff" #else -- If the type is not defined there's not much we can do, other than -- guessing. The values below are correct on Linux amd64. In -- practice it will hopefully not be much of an issue with newer -- versions of GHC, since platforms lacking the definition will -- (hopefully) also not have the relevant types in the available -- APIs. The same remark applies to the types below. int 8 #endif haskellBasicType Tdev_t = #if defined(HTYPE_DEV_T) con0 "SPT.CDev" #else uint 8 #endif haskellBasicType Tgid_t = #if defined(HTYPE_GID_T) con0 "SPT.CGid" #else uint 4 #endif haskellBasicType Tpid_t = #if defined(HTYPE_PID_T) con0 "SPT.CPid" #else int 4 #endif haskellBasicType Tsocklen_t = #if defined(HTYPE_SOCKLEN_T) con0 "SPT.CSocklen" #else uint 4 #endif haskellBasicType Tuid_t = #if defined(HTYPE_UID_T) con0 "SPT.CUid" #else uint 4 #endif -- | Return the unsigned int type with the given amount of bytes. uint :: Int -> TypeRep uint n = con0 ("DW.Word" <> tshow (n*8)) -- | Return the (signed) int type with the given amount of bytes. int :: Int -> TypeRep int n = con0 ("DI.Int" <> tshow (n*8)) -- | This translates GI types to the types used for generated Haskell code. haskellType :: Type -> CodeGen e TypeRep haskellType (TBasicType bt) = return $ haskellBasicType bt -- There is no great choice in this case, so we simply pass the -- pointer along. This is useful for GdkPixbufNotify, for example. haskellType t@(TCArray False (-1) (-1) (TBasicType TUInt8)) = 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 (TGClosure (Just inner@(TInterface n))) = do innerAPI <- getAPI inner case innerAPI of APICallback _ -> do let n' = normalizedAPIName innerAPI n tname <- qualifiedSymbol (callbackCType $ name n') n return $ "GClosure" `con` [con0 tname] -- The given inner type does not make sense, so we treat it as an -- untyped closure. _ -> haskellType (TGClosure Nothing) haskellType (TGClosure _) = do tyvar <- getFreshTypeVariable return $ "GClosure" `con` [con0 tyvar] haskellType TGValue = return $ "GValue" `con` [] haskellType t@(TInterface n) = do api <- getAPI t tname <- qualifiedAPI api n return $ case api of (APIFlags _) -> "[]" `con` [tname `con` []] _ -> tname `con` [] -- | Whether the callable has closure arguments (i.e. "user_data" -- style arguments). callableHasClosures :: Callable -> Bool callableHasClosures c = or . concatMap checkArg $ args c where checkArg :: Arg -> [Bool] checkArg arg = [argClosure arg /= -1, argCallbackUserData arg] -- | Check whether the given type corresponds to a callback. typeIsCallback :: Type -> CodeGen e Bool typeIsCallback t@(TInterface _) = do api <- findAPI t case api of Just (APICallback _) -> return True _ -> return False typeIsCallback _ = return False -- | Basically like `haskellType`, but for types which admit a -- "isomorphic" version of the Haskell type distinct from the usual -- Haskell type. Generally the Haskell type we expose is isomorphic -- to the foreign type, but in some cases, such as callbacks with -- closure arguments, this does not hold, as we omit the closure -- arguments. This function returns a type which is actually -- isomorphic. There is another case this function deals with: for -- convenience untyped `TGClosure` types have a type variable on the -- Haskell side when they are arguments to functions, but we do not -- want this when they appear as arguments to callbacks/signals, or -- return types of properties, as it would force the type synonym/type -- family to depend on the type variable. isoHaskellType :: Type -> CodeGen e TypeRep isoHaskellType (TGClosure Nothing) = return $ "GClosure" `con` [con0 "()"] isoHaskellType t@(TInterface n) = do api <- findAPI t case api of Just apiCB@(APICallback cb) -> do tname <- qualifiedAPI apiCB n if callableHasClosures (cbCallable cb) then return ((callbackHTypeWithClosures tname) `con` []) else return (tname `con` []) _ -> haskellType t isoHaskellType t = haskellType t -- | Foreign (C) type associated to one of the basic types. foreignBasicType :: BasicType -> TypeRep 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 e TypeRep foreignType (TBasicType t) = return $ foreignBasicType t foreignType (TCArray _ _ _ TGValue) = return $ ptr ("B.GValue.GValue" `con` []) 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 (TGClosure Nothing) = return $ ptr ("GClosure" `con` [con0 "()"]) foreignType t@(TGClosure (Just _)) = ptr <$> haskellType t foreignType t@(TGValue) = ptr <$> haskellType t foreignType t@(TInterface n) = do api <- getAPI t let enumIsSigned e = any (< 0) (map enumMemberValue (enumMembers e)) ctypeForEnum e = if enumIsSigned e then "CInt" else "CUInt" case api of APIEnum e -> return $ (ctypeForEnum e) `con` [] APIFlags (Flags e) -> return $ (ctypeForEnum e) `con` [] APICallback _ -> do let n' = normalizedAPIName api n tname <- qualifiedSymbol (callbackCType $ name n') n return (funptr $ tname `con` []) _ -> do tname <- qualifiedAPI api n return (ptr $ tname `con` []) -- | Whether the give type corresponds to an enum or flag. typeIsEnumOrFlag :: Type -> CodeGen e Bool typeIsEnumOrFlag t = do a <- findAPI t case a of Nothing -> return False (Just (APIEnum _)) -> return True (Just (APIFlags _)) -> return True _ -> return False -- | Information on how to allocate a type: allocator function and -- size of the struct. data TypeAllocInfo = TypeAlloc Text Int -- | Information on how to allocate the given type, if known. typeAllocInfo :: Type -> CodeGen e (Maybe TypeAllocInfo) typeAllocInfo TGValue = let n = #{size GValue} in return $ Just $ TypeAlloc ("SP.callocBytes " <> tshow n) n typeAllocInfo (TGArray t) = do api <- findAPI t case api of Just (APIStruct s) -> case structSize s of 0 -> return Nothing n -> let allocator = "B.GArray.allocGArray " <> tshow n in return $ Just $ TypeAlloc allocator n _ -> return Nothing typeAllocInfo t = do api <- findAPI t case api of Just (APIStruct s) -> case structSize s of 0 -> return Nothing n -> let allocator = if structIsBoxed s then "SP.callocBoxedBytes" else "SP.callocBytes" in return $ Just $ TypeAlloc (allocator <> " " <> tshow n) n _ -> return Nothing -- | Returns whether the given type corresponds to a `ManagedPtr` -- instance (a thin wrapper over a `ForeignPtr`). isManaged :: Type -> CodeGen e Bool isManaged TError = return True isManaged TVariant = return True isManaged TGValue = return True isManaged TParamSpec = return True isManaged (TGClosure _) = return True isManaged t@(TInterface _) = 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 isManaged _ = return False -- | Returns whether the given type is represented by a pointer on the -- C side. typeIsPtr :: Type -> CodeGen e Bool typeIsPtr t = isJust <$> typePtrType t -- | Distinct types of foreign pointers. data FFIPtrType = FFIPtr -- ^ Ordinary `Ptr`. | FFIFunPtr -- ^ `FunPtr`. -- | For those types represented by pointers on the C side, return the -- type of pointer which represents them on the Haskell FFI. typePtrType :: Type -> CodeGen e (Maybe FFIPtrType) typePtrType (TBasicType TPtr) = return (Just FFIPtr) typePtrType (TBasicType TUTF8) = return (Just FFIPtr) typePtrType (TBasicType TFileName) = return (Just FFIPtr) typePtrType t = do ft <- foreignType t case typeConName ft of "Ptr" -> return (Just FFIPtr) "FunPtr" -> return (Just FFIFunPtr) _ -> return Nothing -- | If the passed in type is nullable, return the conversion function -- between the FFI pointer type (may be a `Ptr` or a `FunPtr`) and the -- corresponding `Maybe` type. maybeNullConvert :: Type -> CodeGen e (Maybe Text) maybeNullConvert (TBasicType TPtr) = return Nothing maybeNullConvert (TGList _) = return Nothing maybeNullConvert (TGSList _) = return Nothing maybeNullConvert t = do pt <- typePtrType t case pt of Just FFIPtr -> return (Just "SP.convertIfNonNull") Just FFIFunPtr -> return (Just "SP.convertFunPtrIfNonNull") Nothing -> return Nothing -- | An appropriate NULL value for the given type, for types which are -- represented by pointers on the C side. nullPtrForType :: Type -> CodeGen e (Maybe Text) nullPtrForType t = do pt <- typePtrType t case pt of Just FFIPtr -> return (Just "FP.nullPtr") Just FFIFunPtr -> return (Just "FP.nullFunPtr") Nothing -> return Nothing -- | Returns whether the given type should be represented by a -- `Maybe` type on the Haskell side. This applies to all properties -- which have a C representation in terms of pointers, except for -- G(S)Lists, for which NULL is a valid G(S)List, and raw pointers, -- which we just pass through to the Haskell side. Notice that -- introspection annotations can override this. typeIsNullable :: Type -> CodeGen e Bool typeIsNullable t = isJust <$> maybeNullConvert t -- | 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 -> Text -> Maybe (Type, Text) -- ByteString elementTypeAndMap (TCArray _ _ _ (TBasicType TUInt8)) _ = Nothing elementTypeAndMap (TCArray True _ _ t) _ = Just (t, "mapZeroTerminatedCArray") elementTypeAndMap (TCArray _ _ _ TGValue) len = Just (TGValue, parenthesize $ "B.GValue.mapGValueArrayWithLength " <> len) elementTypeAndMap (TCArray False (-1) _ t) len = Just (t, parenthesize $ "mapCArrayWithLength " <> len) elementTypeAndMap (TCArray False fixed _ t) _ = Just (t, parenthesize $ "mapCArrayWithLength " <> tshow 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 -> Text -> Maybe Text elementMap t len = snd <$> elementTypeAndMap t len haskell-gi-0.26.12/lib/Data/GI/CodeGen/CtoHaskellMap.hs0000644000000000000000000002072707346545000020350 0ustar0000000000000000-- | Construct a map from C identifiers to the corresponding Haskell -- elements in the bindings. module Data.GI.CodeGen.CtoHaskellMap ( cToHaskellMap , Hyperlink(..) ) where import qualified Data.Map as M #if !MIN_VERSION_base(4,11,0) import Data.Monoid ((<>)) #endif import Data.Text (Text) import Data.GI.CodeGen.GtkDoc (CRef(..), docName) import Data.GI.CodeGen.API (API(..), Name(..), Callback(..), Constant(..), Flags(..), Enumeration(..), EnumerationMember(..), Interface(..), Object(..), Function(..), Method(..), Struct(..), Union(..), Signal(..), Property(..)) import Data.GI.CodeGen.ModulePath (dotModulePath) import Data.GI.CodeGen.SymbolNaming (moduleLocation, lowerName, upperName, signalHaskellName, haddockSignalAnchor, haddockAttrAnchor, hyphensToCamelCase) import Data.GI.CodeGen.Util (ucFirst, lcFirst) -- | Link to an identifier, module, etc. data Hyperlink = ValueIdentifier Text -- ^ An identifier at the value level: functions, data -- constructors, ... | TypeIdentifier Text -- ^ An identifier at the type level. | ModuleLink Text -- ^ Link to a module. | ModuleLinkWithAnchor (Maybe Text) Text Text -- ^ Link to an anchor inside a given module, with an -- optional label. deriving (Show, Eq) -- | Given a set of APIs, build a `Map` that given a Text -- corresponding to a certain C identifier returns the corresponding -- Haskell element in the bindings. For instance, `gtk_widget_show` -- will get mapped to `GI.Gtk.Objects.Widget.show`. cToHaskellMap :: [(Name, API)] -> M.Map CRef Hyperlink cToHaskellMap apis = M.union (M.fromList builtins) (M.fromList $ concatMap extractRefs apis) where extractRefs :: (Name, API) -> [(CRef, Hyperlink)] extractRefs (n, APIConst c) = constRefs n c extractRefs (n, APIFunction f) = funcRefs n f extractRefs (n, api@(APIEnum e)) = enumRefs api n e extractRefs (n, api@(APIFlags (Flags e))) = enumRefs api n e extractRefs (n, APICallback c) = callbackRefs n c extractRefs (n, APIStruct s) = structRefs n s extractRefs (n, APIUnion u) = unionRefs n u extractRefs (n, APIInterface i) = ifaceRefs n i extractRefs (n, APIObject o) = objectRefs n o builtins :: [(CRef, Hyperlink)] builtins = [(CTypeRef "gboolean", TypeIdentifier "P.Bool"), (ConstantRef "TRUE", ValueIdentifier "P.True"), (ConstantRef "FALSE", ValueIdentifier "P.False"), (CTypeRef "GError", TypeIdentifier "GError"), (CTypeRef "GType", TypeIdentifier "GType"), (CTypeRef "GVariant", TypeIdentifier "GVariant"), (ConstantRef "NULL", ValueIdentifier "P.Nothing")] -- | Obtain the fully qualified symbol pointing to a value. fullyQualifiedValue :: Name -> API -> Text -> Hyperlink fullyQualifiedValue n api symbol = ValueIdentifier $ dotModulePath (moduleLocation n api) <> "." <> symbol -- | Obtain the fully qualified symbol pointing to a type. fullyQualifiedType :: Name -> API -> Text -> Hyperlink fullyQualifiedType n api symbol = TypeIdentifier $ dotModulePath (moduleLocation n api) <> "." <> symbol -- | Extract the C name of a constant. These are often referred to as -- types, so we allow that too. constRefs :: Name -> Constant -> [(CRef, Hyperlink)] constRefs n c = [(ConstantRef (constantCType c), qualified), (CTypeRef (constantCType c), qualified), (TypeRef (docName n), qualified)] where qualified = fullyQualifiedValue n (APIConst c) $ name n -- | Extract the C name of a function. funcRefs :: Name -> Function -> [(CRef, Hyperlink)] funcRefs n f = [(OldFunctionRef (fnSymbol f), qualified), (FunctionRef (docName n), qualified)] where qualified = fullyQualifiedValue n (APIFunction f) $ lowerName n -- | Extract the C names of the fields in an enumeration/flags, and -- the name of the type itself. enumRefs :: API -> Name -> Enumeration -> [(CRef, Hyperlink)] enumRefs api n e = (CTypeRef (enumCType e), qualified) : (TypeRef (docName n), qualified) : map memberToRef (enumMembers e) where qualified = fullyQualifiedType n api $ upperName n memberToRef :: EnumerationMember -> (CRef, Hyperlink) memberToRef em = (ConstantRef (enumMemberCId em), fullyQualifiedValue n api $ upperName $ n {name = name n <> "_" <> enumMemberName em}) -- | Refs to the methods for a given owner. methodRefs :: Name -> API -> [Method] -> [(CRef, Hyperlink)] methodRefs n api methods = concatMap methodRef methods where methodRef :: Method -> [(CRef, Hyperlink)] methodRef Method{methodSymbol = symbol, methodName = mn} = -- Method name namespaced by the owner. let mn' = mn {name = name n <> "_" <> name mn} qualified = fullyQualifiedValue n api $ lowerName mn' in [(OldFunctionRef symbol, qualified), (MethodRef (docName n) (name mn), qualified)] -- | Refs to the signals for a given owner. signalRefs :: Name -> API -> Maybe Text -> [Signal] -> [(CRef, Hyperlink)] signalRefs n@(Name _ owner) api maybeCName signals = concatMap signalRef signals where signalRef :: Signal -> [(CRef, Hyperlink)] signalRef (Signal {sigName = sn}) = let mod = dotModulePath (moduleLocation n api) sn' = signalHaskellName sn ownerCName = case maybeCName of Just cname -> cname Nothing -> let Name ns owner = n in ucFirst ns <> owner label = Just (owner <> "::" <> sn') link = ModuleLinkWithAnchor label mod (haddockSignalAnchor <> sn') in [(OldSignalRef ownerCName sn, link), (SignalRef (docName n) sn, link)] -- | Refs to the properties for a given owner. propRefs :: Name -> API -> Maybe Text -> [Property] -> [(CRef, Hyperlink)] propRefs n@(Name _ owner) api maybeCName props = concatMap propertyRef props where propertyRef :: Property -> [(CRef, Hyperlink)] propertyRef (Property {propName = pn}) = let mod = dotModulePath (moduleLocation n api) hn = lcFirst . hyphensToCamelCase $ pn ownerCName = case maybeCName of Just cname -> cname Nothing -> let Name ns owner = n in ucFirst ns <> owner label = Just (owner <> ":" <> hn) link = ModuleLinkWithAnchor label mod (haddockAttrAnchor <> hn) in [(OldPropertyRef ownerCName pn, link), (PropertyRef (docName n) pn, link)] -- | Given an optional C type and the API constructor construct the -- list of associated refs. maybeCType :: Name -> API -> Maybe Text -> [(CRef, Hyperlink)] maybeCType _ _ Nothing = [] maybeCType n api (Just ctype) = [(CTypeRef ctype, qualified), (TypeRef (docName n), qualified)] where qualified = fullyQualifiedType n api (upperName n) -- | Extract the C name of a callback. callbackRefs :: Name -> Callback -> [(CRef, Hyperlink)] callbackRefs n cb = maybeCType n (APICallback cb) (cbCType cb) -- | Extract the C references in a struct. structRefs :: Name -> Struct -> [(CRef, Hyperlink)] structRefs n s = maybeCType n (APIStruct s) (structCType s) <> methodRefs n (APIStruct s) (structMethods s) -- | Extract the C references in a union. unionRefs :: Name -> Union -> [(CRef, Hyperlink)] unionRefs n u = maybeCType n (APIUnion u) (unionCType u) <> methodRefs n (APIUnion u) (unionMethods u) -- | Extract the C references in an interface. ifaceRefs :: Name -> Interface -> [(CRef, Hyperlink)] ifaceRefs n i = maybeCType n (APIInterface i) (ifCType i) <> methodRefs n (APIInterface i) (ifMethods i) <> signalRefs n (APIInterface i) (ifCType i) (ifSignals i) -- | Extract the C references in an object. objectRefs :: Name -> Object -> [(CRef, Hyperlink)] objectRefs n o = maybeCType n (APIObject o) (objCType o) <> methodRefs n (APIObject o) (objMethods o) <> signalRefs n (APIObject o) (objCType o) (objSignals o) <> propRefs n (APIObject o) (objCType o) (objProperties o) haskell-gi-0.26.12/lib/Data/GI/CodeGen/CtoHaskellMap.hs-boot0000644000000000000000000000041207346545000021276 0ustar0000000000000000module Data.GI.CodeGen.CtoHaskellMap ( cToHaskellMap, Hyperlink ) where import qualified Data.Map as M import Data.GI.CodeGen.GtkDoc (CRef(..)) import Data.GI.CodeGen.API (API(..), Name(..)) data Hyperlink cToHaskellMap :: [(Name, API)] -> M.Map CRef Hyperlink haskell-gi-0.26.12/lib/Data/GI/CodeGen/EnumFlags.hs0000644000000000000000000001556707346545000017550 0ustar0000000000000000-- | Support for enums and flags. module Data.GI.CodeGen.EnumFlags ( genEnum , genFlags ) where import Control.Monad (when, forM_) #if !MIN_VERSION_base(4,11,0) import Data.Monoid ((<>)) #endif import Data.Text (Text) import qualified Data.Set as S import Foreign.C (CUInt) import Foreign.Storable (sizeOf) import Data.GI.CodeGen.API import Data.GI.CodeGen.Code import Data.GI.CodeGen.Haddock (deprecatedPragma, writeDocumentation, writeHaddock, RelativeDocPosition(..)) import Data.GI.CodeGen.SymbolNaming (upperName) import Data.GI.CodeGen.Util (tshow) -- | Given a list of named enum members, filter out those that have -- the same value as a previous entry in the list. dropDuplicated :: [(Text, EnumerationMember)] -> [(Text, EnumerationMember)] dropDuplicated namedMembers = go namedMembers enumMemberValue S.empty where go :: Ord c => [(a, b)] -> (b->c) -> S.Set c -> [(a, b)] go [] _ _ = [] go ((n, m) : rest) f seen = if S.member (f m) seen -- already seen, discard then go rest f seen else (n,m) : go rest f (S.insert (f m) seen) genEnumOrFlags :: HaddockSection -> Name -> Enumeration -> ExcCodeGen () genEnumOrFlags docSection n@(Name ns name) e = do -- Conversion functions expect enums and flags to map to CUInt, -- which we assume to be of 32 bits. Fail early, instead of giving -- strange errors at runtime. when (sizeOf (0 :: CUInt) /= 4) $ notImplementedError $ "Unsupported CUInt size: " <> tshow (sizeOf (0 :: CUInt)) when (enumStorageBytes e /= 4) $ notImplementedError $ "Storage of size /= 4 not supported : " <> tshow (enumStorageBytes e) let name' = upperName n members' = flip map (enumMembers e) $ \member -> let n = upperName $ Name ns (name <> "_" <> enumMemberName member) in (n, member) deprecatedPragma name' (enumDeprecated e) group $ do export docSection (name' <> "(..)") hsBoot . line $ "data " <> name' writeDocumentation DocBeforeSymbol (enumDocumentation e) line $ "data " <> name' <> " = " indent $ case members' of ((fieldName, firstMember):fs) -> do line $ " " <> fieldName writeDocumentation DocAfterSymbol (enumMemberDoc firstMember) forM_ fs $ \(n, member) -> do line $ "| " <> n writeDocumentation DocAfterSymbol (enumMemberDoc member) line $ "| Another" <> name' <> " Int" writeHaddock DocAfterSymbol "Catch-all for unknown values" line "deriving (Show, Eq)" _ -> return () group $ do bline $ "instance P.Enum " <> name' <> " where" indent $ do forM_ members' $ \(n, m) -> line $ "fromEnum " <> n <> " = " <> tshow (enumMemberValue m) line $ "fromEnum (Another" <> name' <> " k) = k" blank indent $ do forM_ (dropDuplicated members') $ \(n, m) -> line $ "toEnum " <> tshow (enumMemberValue m) <> " = " <> n line $ "toEnum k = Another" <> name' <> " k" group $ do line $ "instance P.Ord " <> name' <> " where" indent $ line "compare a b = P.compare (P.fromEnum a) (P.fromEnum b)" maybe (return ()) (genErrorDomain docSection name') (enumErrorDomain e) genBoxedEnum :: Name -> Text -> CodeGen e () genBoxedEnum n typeInit = do let name' = upperName n group $ do line $ "type instance O.ParentTypes " <> name' <> " = '[]" bline $ "instance O.HasParentTypes " <> name' group $ do line $ "foreign import ccall \"" <> typeInit <> "\" c_" <> typeInit <> " :: " indent $ line "IO GType" group $ do bline $ "instance B.Types.TypedObject " <> name' <> " where" indent $ line $ "glibType = c_" <> typeInit group $ do bline $ "instance B.Types.BoxedEnum " <> name' genEnum :: Name -> Enumeration -> CodeGen e () genEnum n@(Name _ name) enum = do line $ "-- Enum " <> name let docSection = NamedSubsection EnumSection (upperName n) handleCGExc (\e -> do line $ "-- XXX Code Generation error" printCGError e) (do genEnumOrFlags docSection n enum case enumTypeInit enum of Nothing -> return () Just ti -> genBoxedEnum n ti) genBoxedFlags :: Name -> Text -> CodeGen e () genBoxedFlags n typeInit = do let name' = upperName n group $ do line $ "type instance O.ParentTypes " <> name' <> " = '[]" bline $ "instance O.HasParentTypes " <> name' group $ do line $ "foreign import ccall \"" <> typeInit <> "\" c_" <> typeInit <> " :: " indent $ line "IO GType" group $ do bline $ "instance B.Types.TypedObject " <> name' <> " where" indent $ line $ "glibType = c_" <> typeInit group $ do bline $ "instance B.Types.BoxedFlags " <> name' -- | Very similar to enums, but we also declare ourselves as members of -- the IsGFlag typeclass. genFlags :: Name -> Flags -> CodeGen e () genFlags n@(Name _ name) (Flags enum) = do line $ "-- Flags " <> name let docSection = NamedSubsection FlagSection (upperName n) handleCGExc (\e -> do line "-- XXX Code generation error" printCGError e) (do genEnumOrFlags docSection n enum case enumTypeInit enum of Nothing -> return () Just ti -> genBoxedFlags n ti let name' = upperName n group $ bline $ "instance IsGFlag " <> name') -- | Support for enums encapsulating error codes. genErrorDomain :: HaddockSection -> Text -> Text -> CodeGen e () genErrorDomain docSection name' domain = do group $ do line $ "instance GErrorClass " <> name' <> " where" indent $ line $ "gerrorClassDomain _ = \"" <> domain <> "\"" -- Generate type specific error handling (saves a bit of typing, and -- it's clearer to read). group $ do let catcher = "catch" <> name' writeHaddock DocBeforeSymbol catcherDoc line $ catcher <> " ::" indent $ do line "IO a ->" line $ "(" <> name' <> " -> GErrorMessage -> IO a) ->" line "IO a" line $ catcher <> " = catchGErrorJustDomain" group $ do let handler = "handle" <> name' writeHaddock DocBeforeSymbol handleDoc line $ handler <> " ::" indent $ do line $ "(" <> name' <> " -> GErrorMessage -> IO a) ->" line "IO a ->" line "IO a" line $ handler <> " = handleGErrorJustDomain" export docSection ("catch" <> name') export docSection ("handle" <> name') where catcherDoc :: Text catcherDoc = "Catch exceptions of type `" <> name' <> "`. This is a specialized version of `Data.GI.Base.GError.catchGErrorJustDomain`." handleDoc :: Text handleDoc = "Handle exceptions of type `" <> name' <> "`. This is a specialized version of `Data.GI.Base.GError.handleGErrorJustDomain`." haskell-gi-0.26.12/lib/Data/GI/CodeGen/Fixups.hs0000644000000000000000000003166707346545000017144 0ustar0000000000000000-- | Various fixups in the introspection data. module Data.GI.CodeGen.Fixups ( dropMovedItems , guessPropertyNullability , detectGObject , dropDuplicatedFields , checkClosureDestructors , fixClosures , fixCallbackUserData , fixSymbolNaming ) where import Data.Char (generalCategory, GeneralCategory(UppercaseLetter)) import Data.Maybe (isNothing, isJust) import qualified Data.Map as M #if !MIN_VERSION_base(4,13,0) import Data.Monoid ((<>)) #endif import qualified Data.Set as S import qualified Data.Text as T import Data.GI.CodeGen.Type import Data.GI.CodeGen.API -- | Remove functions and methods annotated with "moved-to". dropMovedItems :: API -> Maybe API dropMovedItems (APIFunction f) = if fnMovedTo f == Nothing then Just (APIFunction f) else Nothing dropMovedItems (APIInterface i) = (Just . APIInterface) i {ifMethods = filterMovedMethods (ifMethods i)} dropMovedItems (APIObject o) = (Just . APIObject) o {objMethods = filterMovedMethods (objMethods o)} dropMovedItems (APIStruct s) = (Just . APIStruct) s {structMethods = filterMovedMethods (structMethods s)} dropMovedItems (APIUnion u) = (Just . APIUnion) u {unionMethods = filterMovedMethods (unionMethods u)} dropMovedItems a = Just a -- | Drop the moved methods. filterMovedMethods :: [Method] -> [Method] filterMovedMethods = filter (isNothing . methodMovedTo) -- | GObject-introspection does not currently support nullability -- annotations, so we try to guess the nullability from the -- nullability annotations of the curresponding get/set methods, which -- in principle should be reliable. guessPropertyNullability :: (Name, API) -> (Name, API) guessPropertyNullability (n, APIObject obj) = (n, APIObject (guessObjectPropertyNullability obj)) guessPropertyNullability (n, APIInterface iface) = (n, APIInterface (guessInterfacePropertyNullability iface)) guessPropertyNullability other = other -- | Guess nullability for the properties of an object. guessObjectPropertyNullability :: Object -> Object guessObjectPropertyNullability obj = obj {objProperties = map (guessNullability (objMethods obj)) (objProperties obj)} -- | Guess nullability for the properties of an interface. guessInterfacePropertyNullability :: Interface -> Interface guessInterfacePropertyNullability iface = iface {ifProperties = map (guessNullability (ifMethods iface)) (ifProperties iface)} -- | Guess the nullability for a property, given the list of methods -- for the object/interface. guessNullability :: [Method] -> Property -> Property guessNullability methods = guessReadNullability methods . guessWriteNullability methods -- | Guess whether "get" on the given property may return NULL, based -- on the corresponding "get_prop_name" method, if it exists. guessReadNullability :: [Method] -> Property -> Property guessReadNullability methods p | isJust (propReadNullable p) = p | otherwise = p {propReadNullable = nullableGetter} where nullableGetter :: Maybe Bool nullableGetter = let prop_name = T.replace "-" "_" (propName p) in case findMethod methods ("get_" <> prop_name) of Nothing -> Nothing -- Check that it looks like a sensible getter -- for the property. Just m -> let c = methodCallable m in if length (args c) == 1 && returnType c == Just (propType p) && returnTransfer c == TransferNothing && skipReturn c == False && callableThrows c == False && methodType m == OrdinaryMethod && methodMovedTo m == Nothing then Just (returnMayBeNull c) else Nothing -- | Guess whether "set" on the given property may return NULL, based -- on the corresponding "set_prop_name" method, if it exists. guessWriteNullability :: [Method] -> Property -> Property guessWriteNullability methods p | isJust (propWriteNullable p) = p | otherwise = p {propWriteNullable = nullableSetter} where nullableSetter :: Maybe Bool nullableSetter = let prop_name = T.replace "-" "_" (propName p) in case findMethod methods ("set_" <> prop_name) of Nothing -> Nothing -- Check that it looks like a sensible setter. Just m -> let c = methodCallable m in if length (args c) == 2 && (argType . last . args) c == propType p && returnType c == Nothing && (transfer . last . args) c == TransferNothing && (direction . last . args) c == DirectionIn && methodMovedTo m == Nothing && methodType m == OrdinaryMethod && callableThrows c == False then Just ((mayBeNull . last . args) c) else Nothing -- | Find the first method with the given name, if any. findMethod :: [Method] -> T.Text -> Maybe Method findMethod methods n = case filter ((== n) . name . methodName) methods of [m] -> Just m _ -> Nothing -- | Not every interface that provides signals/properties is marked as -- requiring GObject, but this is necessarily the case, so fix the -- introspection data accordingly. detectGObject :: (Name, API) -> (Name, API) detectGObject (n, APIInterface iface) = if not (null (ifProperties iface) && null (ifSignals iface)) then let gobject = Name "GObject" "Object" in if gobject `elem` (ifPrerequisites iface) then (n, APIInterface iface) else (n, APIInterface (iface {ifPrerequisites = gobject : ifPrerequisites iface})) else (n, APIInterface iface) detectGObject api = api -- | Drop any fields whose name coincides with that of a previous -- element. Note that this function keeps ordering. dropDuplicatedEnumFields :: Enumeration -> Enumeration dropDuplicatedEnumFields enum = enum{enumMembers = dropDuplicates S.empty (enumMembers enum)} where dropDuplicates :: S.Set T.Text -> [EnumerationMember] -> [EnumerationMember] dropDuplicates _ [] = [] dropDuplicates previous (m:ms) = if enumMemberName m `S.member` previous then dropDuplicates previous ms else m : dropDuplicates (S.insert (enumMemberName m) previous) ms -- | Some libraries include duplicated flags by mistake, drop those. dropDuplicatedFields :: (Name, API) -> (Name, API) dropDuplicatedFields (n, APIFlags (Flags enum)) = (n, APIFlags (Flags $ dropDuplicatedEnumFields enum)) dropDuplicatedFields (n, api) = (n, api) -- | Sometimes arguments are marked as being a user_data destructor, -- but there is no associated user_data argument. In this case we drop -- the annotation. checkClosureDestructors :: (Name, API) -> (Name, API) checkClosureDestructors (n, APIObject o) = (n, APIObject (o {objMethods = checkMethodDestructors (objMethods o)})) checkClosureDestructors (n, APIInterface i) = (n, APIInterface (i {ifMethods = checkMethodDestructors (ifMethods i)})) checkClosureDestructors (n, APIStruct s) = (n, APIStruct (s {structMethods = checkMethodDestructors (structMethods s)})) checkClosureDestructors (n, APIUnion u) = (n, APIUnion (u {unionMethods = checkMethodDestructors (unionMethods u)})) checkClosureDestructors (n, APIFunction f) = (n, APIFunction (f {fnCallable = checkCallableDestructors (fnCallable f)})) checkClosureDestructors (n, api) = (n, api) checkMethodDestructors :: [Method] -> [Method] checkMethodDestructors = map checkMethod where checkMethod :: Method -> Method checkMethod m = m {methodCallable = checkCallableDestructors (methodCallable m)} -- | If any argument for the callable has an associated destroyer for -- the user_data, but no associated user_data, drop the destroyer -- annotation. checkCallableDestructors :: Callable -> Callable checkCallableDestructors c = c {args = map checkArg (args c)} where checkArg :: Arg -> Arg checkArg arg = if argDestroy arg >= 0 && argClosure arg == -1 then arg {argDestroy = -1} else arg -- | Sometimes it is the callback that is annotated with the (closure -- user_data) annotation, and sometimes the user_data parameter -- itself, with (closure callback) pointing to the callback. The -- following code makes sure that the annotation is on the callable -- only. Note that this goes against the official gobject -- introspection spec, but there is more code using this convention -- than otherwise, and the gir generator seems to add closure -- annotations in both directions when using the new convention -- anyway. fixCallableClosures :: Callable -> Callable fixCallableClosures c = c {args = map fixupArg (zip [0..] (args c))} where fixupArg :: (Int, Arg) -> Arg fixupArg (n, arg) = if isUserData arg then arg {argClosure = -1} else case M.lookup n reverseMap of Just user_data -> arg {argClosure = user_data} Nothing -> arg -- Map from callbacks to their corresponding user_data -- arguments, obtained by looking to the argClosure value for -- the user_data argument. reverseMap :: M.Map Int Int reverseMap = M.fromList . map (\(n, arg) -> (argClosure arg, n)) . filter (isUserData . snd) . filter ((/= -1) . argClosure . snd) $ zip [0..] (args c) isUserData :: Arg -> Bool isUserData arg = argScope arg == ScopeTypeInvalid || argType arg == TBasicType TPtr -- | Closures are often incorrectly assigned, with the closure -- annotation on the callback, instead of in the closure (user_data) -- parameter itself. The following makes sure that things are as they -- should. fixClosures :: (Name, API) -> (Name, API) fixClosures (n, APIObject o) = (n, APIObject (o {objMethods = fixMethodClosures (objMethods o)})) fixClosures (n, APIInterface i) = (n, APIInterface (i {ifMethods = fixMethodClosures (ifMethods i)})) fixClosures (n, APIStruct s) = (n, APIStruct (s {structMethods = fixMethodClosures (structMethods s)})) fixClosures (n, APIUnion u) = (n, APIUnion (u {unionMethods = fixMethodClosures (unionMethods u)})) fixClosures (n, APIFunction f) = (n, APIFunction (f {fnCallable = fixCallableClosures (fnCallable f)})) fixClosures (n, api) = (n, api) fixMethodClosures :: [Method] -> [Method] fixMethodClosures = map fixMethod where fixMethod :: Method -> Method fixMethod m = m {methodCallable = fixCallableClosures (methodCallable m)} -- | The last argument of callbacks is often a @user_data@ argument, -- but currently gobject-introspection does not have an annotation -- representing this. This is generally OK, since the gir generator -- will mark these arguments as @(closure)@ if they are named -- @user_data@, and we do the right things in this case, but recently -- there has been a push to "fix" these annotations by removing them -- without providing any replacement, which breaks the bindings. See -- https://gitlab.gnome.org/GNOME/gobject-introspection/-/issues/450 -- Here we try to guess which arguments in callbacks are user_data -- arguments. fixCallbackUserData :: (Name, API) -> (Name, API) fixCallbackUserData (n, APICallback cb) = (n, APICallback (cb {cbCallable = fixCallableUserData (cbCallable cb)})) fixCallbackUserData (n, api) = (n, api) -- | Any argument with a closure index pointing to itself is a -- "user_data" type argument. fixCallableUserData :: Callable -> Callable fixCallableUserData c = c {args = fixLast 0 (args c)} where fixLast :: Int -> [Arg] -> [Arg] fixLast _ [] = [] fixLast n (arg:[]) | argType arg == TBasicType TPtr && argClosure arg == n = [arg {argClosure = -1, argCallbackUserData = True}] | otherwise = [arg] fixLast n (arg:rest) = arg : fixLast (n+1) rest -- | Some symbols have names that are not valid Haskell identifiers, -- fix that here. fixSymbolNaming :: (Name, API) -> (Name, API) fixSymbolNaming (n, APIConst c) = (fixConstantName n, APIConst c) fixSymbolNaming (n, api) = (n, api) -- | Make sure that the given name is a valid Haskell identifier in -- patterns. -- -- === __Examples__ -- >>> fixConstantName (Name "IBus" "0") -- Name {namespace = "IBus", name = "C'0"} -- -- >>> fixConstantName (Name "IBus" "a") -- Name {namespace = "IBus", name = "C'a"} -- -- >>> fixConstantName (Name "IBus" "A") -- Name {namespace = "IBus", name = "A"} fixConstantName :: Name -> Name fixConstantName (Name ns n) | not (T.null n) && generalCategory (T.head n) /= UppercaseLetter = Name ns ("C'" <> n) | otherwise = Name ns n haskell-gi-0.26.12/lib/Data/GI/CodeGen/GObject.hs0000644000000000000000000000277607346545000017202 0ustar0000000000000000module Data.GI.CodeGen.GObject ( isGObject , apiIsGObject , nameIsGObject ) where #if !MIN_VERSION_base(4,8,0) import Control.Applicative ((<$>)) #endif import Data.GI.CodeGen.API import Data.GI.CodeGen.Code import Data.GI.CodeGen.Type -- Returns whether the given type is a descendant of the given parent. typeDoParentSearch :: Name -> Type -> CodeGen e Bool typeDoParentSearch parent (TInterface n) = findAPIByName n >>= apiDoParentSearch parent n typeDoParentSearch _ _ = return False apiDoParentSearch :: Name -> Name -> API -> CodeGen e Bool apiDoParentSearch parent n api | parent == n = return True | otherwise = case api of APIObject o -> case objParent o of Just p -> typeDoParentSearch parent (TInterface p) Nothing -> return False APIInterface iface -> do let prs = ifPrerequisites iface prereqs <- zip prs <$> mapM findAPIByName prs or <$> mapM (uncurry (apiDoParentSearch parent)) prereqs _ -> return False -- | Check whether the given type descends from GObject. isGObject :: Type -> CodeGen e Bool isGObject = typeDoParentSearch $ Name "GObject" "Object" -- | Check whether the given name descends from GObject. nameIsGObject :: Name -> CodeGen e Bool nameIsGObject n = findAPIByName n >>= apiIsGObject n -- | Check whether the given API descends from GObject. apiIsGObject :: Name -> API -> CodeGen e Bool apiIsGObject = apiDoParentSearch $ Name "GObject" "Object" haskell-gi-0.26.12/lib/Data/GI/CodeGen/GType.hsc0000644000000000000000000000120107346545000017036 0ustar0000000000000000module Data.GI.CodeGen.GType ( GType -- Reexport from Data.GI.Base.BasicTypes for convenience , gtypeIsA , gtypeIsBoxed ) where #include 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 haskell-gi-0.26.12/lib/Data/GI/CodeGen/GtkDoc.hs0000644000000000000000000005667707346545000017051 0ustar0000000000000000-- | A parser for gtk-doc formatted documentation, see -- https://developer.gnome.org/gtk-doc-manual/ for the spec. module Data.GI.CodeGen.GtkDoc ( parseGtkDoc , GtkDoc(..) , Token(..) , Language(..) , Link(..) , ListItem(..) , CRef(..) , DocSymbolName(..) , docName , resolveDocSymbol ) where import Prelude hiding (takeWhile) #if !MIN_VERSION_base(4,8,0) import Control.Applicative ((<$>), (<*)) #endif #if !MIN_VERSION_base(4,13,0) import Data.Monoid ((<>)) #endif import Control.Applicative ((<|>)) import Data.GI.GIR.BasicTypes (Name(Name)) import Data.Attoparsec.Text import Data.Char (isAlphaNum, isAlpha, isAscii) import qualified Data.Text as T import Data.Text (Text) -- | A parsed gtk-doc token. data Token = Literal Text | Comment Text | Verbatim Text | CodeBlock (Maybe Language) Text | ExternalLink Link | Image Link | List [ListItem] | SectionHeader Int GtkDoc -- ^ A section header of the given depth. | SymbolRef CRef deriving (Show, Eq) -- | A link to a resource, either offline or a section of the documentation. data Link = Link { linkName :: Text , linkAddress :: Text } deriving (Show, Eq) -- | An item in a list, given by a list of lines (not including ending -- newlines). The list is always non-empty, so we represent it by the -- first line and then a possibly empty list with the rest of the -- lines. data ListItem = ListItem GtkDoc [GtkDoc] deriving (Show, Eq) -- | The language for an embedded code block. newtype Language = Language Text deriving (Show, Eq) -- | A reference to some symbol in the API. data CRef = FunctionRef DocSymbolName | OldFunctionRef Text | MethodRef DocSymbolName Text | ParamRef Text | ConstantRef Text | SignalRef DocSymbolName Text | OldSignalRef Text Text | LocalSignalRef Text | PropertyRef DocSymbolName Text | OldPropertyRef Text Text | VMethodRef Text Text | VFuncRef DocSymbolName Text | StructFieldRef Text Text | CTypeRef Text | TypeRef DocSymbolName deriving (Show, Eq, Ord) -- | Reference to a name (of a class, for instance) in the -- documentation. It can be either relative to the module where the -- documentation is, of in some other namespace. data DocSymbolName = RelativeName Text -- ^ The symbol without a namespace specified | AbsoluteName Text Text -- ^ Namespace and symbol deriving (Show, Eq, Ord) -- | A parsed gtk-doc with fully resolved references. newtype GtkDoc = GtkDoc [Token] deriving (Show, Eq) -- | Parse the given gtk-doc formatted documentation. -- -- === __Examples__ -- >>> parseGtkDoc "" -- GtkDoc [] -- -- >>> parseGtkDoc "func()" -- GtkDoc [SymbolRef (OldFunctionRef "func")] -- -- >>> parseGtkDoc "literal" -- GtkDoc [Literal "literal"] -- -- >>> parseGtkDoc "This is a long literal" -- GtkDoc [Literal "This is a long literal"] -- -- >>> parseGtkDoc "Call foo() for free cookies" -- GtkDoc [Literal "Call ",SymbolRef (OldFunctionRef "foo"),Literal " for free cookies"] -- -- >>> parseGtkDoc "The signal ::activate is related to gtk_button_activate()." -- GtkDoc [Literal "The signal ",SymbolRef (LocalSignalRef "activate"),Literal " is related to ",SymbolRef (OldFunctionRef "gtk_button_activate"),Literal "."] -- -- >>> parseGtkDoc "The signal ##%#GtkButton::activate is related to gtk_button_activate()." -- GtkDoc [Literal "The signal ##%",SymbolRef (OldSignalRef "GtkButton" "activate"),Literal " is related to ",SymbolRef (OldFunctionRef "gtk_button_activate"),Literal "."] -- -- >>> parseGtkDoc "# A section\n\n## and a subsection ##\n" -- GtkDoc [SectionHeader 1 (GtkDoc [Literal "A section"]),Literal "\n",SectionHeader 2 (GtkDoc [Literal "and a subsection "])] -- -- >>> parseGtkDoc "Compact list:\n- First item\n- Second item" -- GtkDoc [Literal "Compact list:\n",List [ListItem (GtkDoc [Literal "First item"]) [],ListItem (GtkDoc [Literal "Second item"]) []]] -- -- >>> parseGtkDoc "Spaced list:\n\n- First item\n\n- Second item" -- GtkDoc [Literal "Spaced list:\n",List [ListItem (GtkDoc [Literal "First item"]) [],ListItem (GtkDoc [Literal "Second item"]) []]] -- -- >>> parseGtkDoc "List with urls:\n- [test](http://test)\n- ![](image.png)" -- GtkDoc [Literal "List with urls:\n",List [ListItem (GtkDoc [ExternalLink (Link {linkName = "test", linkAddress = "http://test"})]) [],ListItem (GtkDoc [Image (Link {linkName = "", linkAddress = "image.png"})]) []]] parseGtkDoc :: Text -> GtkDoc parseGtkDoc raw = case parseOnly (parseTokens <* endOfInput) raw of Left e -> error $ "gtk-doc parsing failed with error \"" <> e <> "\" on the input \"" <> T.unpack raw <> "\"" Right tks -> GtkDoc . coalesceLiterals . restoreSHPreNewlines . restoreListPreNewline $ tks -- | `parseSectionHeader` eats the newline before the section header, -- but `parseInitialSectionHeader` does not, since it only matches at -- the beginning of the text. This restores the newlines eaten by -- `parseSectionHeader`, so a `SectionHeader` returned by the parser -- can always be assumed /not/ to have an implicit starting newline. restoreSHPreNewlines :: [Token] -> [Token] restoreSHPreNewlines [] = [] restoreSHPreNewlines (i : rest) = i : restoreNewlines rest where restoreNewlines :: [Token] -> [Token] restoreNewlines [] = [] restoreNewlines (s@(SectionHeader _ _) : rest) = Literal "\n" : s : restoreNewlines rest restoreNewlines (x : rest) = x : restoreNewlines rest -- | `parseList` eats the newline before the list, restore it. restoreListPreNewline :: [Token] -> [Token] restoreListPreNewline [] = [] restoreListPreNewline (l@(List _) : rest) = Literal "\n" : l : restoreListPreNewline rest restoreListPreNewline (x : rest) = x : restoreListPreNewline rest -- | Accumulate consecutive literals into a single literal. coalesceLiterals :: [Token] -> [Token] coalesceLiterals tks = go Nothing tks where go :: Maybe Text -> [Token] -> [Token] go Nothing [] = [] go (Just l) [] = [Literal l] go Nothing (Literal l : rest) = go (Just l) rest go (Just l) (Literal l' : rest) = go (Just (l <> l')) rest go Nothing (tk : rest) = tk : go Nothing rest go (Just l) (tk : rest) = Literal l : tk : go Nothing rest -- | Parser for tokens. parseTokens :: Parser [Token] parseTokens = headerAndTokens <|> justTokens where -- In case the input starts by a section header. headerAndTokens :: Parser [Token] headerAndTokens = do header <- parseInitialSectionHeader tokens <- justTokens return (header : tokens) justTokens :: Parser [Token] justTokens = many' parseToken -- | Parse a single token. -- -- === __Examples__ -- >>> parseOnly (parseToken <* endOfInput) "func()" -- Right (SymbolRef (OldFunctionRef "func")) parseToken :: Parser Token parseToken = -- Note that the parsers overlap, so this is not as -- efficient as it could be (if we had combined parsers -- and then branched, so that there is no -- backtracking). But speed is not an issue here, so for -- clarity we keep the parsers distinct. The exception -- is parseFunctionRef, since it does not complicate the -- parser much, and it is the main source of -- backtracking. parseFunctionRef <|> parseMethod <|> parseConstructor <|> parseSignal <|> parseId <|> parseLocalSignal <|> parseProperty <|> parseVMethod <|> parseStructField <|> parseClass <|> parseCType <|> parseConstant <|> parseParam <|> parseEscaped <|> parseCodeBlock <|> parseVerbatim <|> parseUrl <|> parseImage <|> parseSectionHeader <|> parseList <|> parseComment <|> parseBoringLiteral -- | Whether the given character is valid in a C identifier. isCIdent :: Char -> Bool isCIdent '_' = True isCIdent c = isAscii c && isAlphaNum c -- | Something that could be a valid C identifier (loosely speaking, -- we do not need to be too strict here). parseCIdent :: Parser Text parseCIdent = takeWhile1 isCIdent -- | Parse a function ref parseFunctionRef :: Parser Token parseFunctionRef = parseOldFunctionRef <|> parseNewFunctionRef -- | Parse an unresolved reference to a C symbol in new gtk-doc notation. parseId :: Parser Token parseId = do _ <- string "[id@" ident <- parseCIdent _ <- char ']' return (SymbolRef (OldFunctionRef ident)) -- | Parse a function ref, given by a valid C identifier followed by -- '()', for instance 'gtk_widget_show()'. If the identifier is not -- followed by "()", return it as a literal instead. -- -- === __Examples__ -- >>> parseOnly (parseFunctionRef <* endOfInput) "test_func()" -- Right (SymbolRef (OldFunctionRef "test_func")) -- -- >>> parseOnly (parseFunctionRef <* endOfInput) "not_a_func" -- Right (Literal "not_a_func") parseOldFunctionRef :: Parser Token parseOldFunctionRef = do ident <- parseCIdent option (Literal ident) (string "()" >> return (SymbolRef (OldFunctionRef ident))) -- | Parse a function name in new style, of the form -- > [func@Namespace.c_func_name] -- -- === __Examples__ -- >>> parseOnly (parseFunctionRef <* endOfInput) "[func@Gtk.init]" -- Right (SymbolRef (FunctionRef (AbsoluteName "Gtk" "init"))) parseNewFunctionRef :: Parser Token parseNewFunctionRef = do _ <- string "[func@" ns <- takeWhile1 (\c -> isAscii c && isAlpha c) _ <- char '.' n <- takeWhile1 isCIdent _ <- char ']' return $ SymbolRef $ FunctionRef (AbsoluteName ns n) -- | Parse a method name, of the form -- > [method@Namespace.Object.c_func_name] -- -- === __Examples__ -- >>> parseOnly (parseMethod <* endOfInput) "[method@Gtk.Button.set_child]" -- Right (SymbolRef (MethodRef (AbsoluteName "Gtk" "Button") "set_child")) parseMethod :: Parser Token parseMethod = do _ <- string "[method@" ns <- takeWhile1 (\c -> isAscii c && isAlpha c) _ <- char '.' n <- takeWhile1 isCIdent _ <- char '.' method <- takeWhile1 isCIdent _ <- char ']' return $ SymbolRef $ MethodRef (AbsoluteName ns n) method -- | Parse a reference to a constructor, of the form -- > [ctor@Namespace.Object.c_func_name] -- -- === __Examples__ -- >>> parseOnly (parseConstructor <* endOfInput) "[ctor@Gtk.Builder.new_from_file]" -- Right (SymbolRef (MethodRef (AbsoluteName "Gtk" "Builder") "new_from_file")) parseConstructor :: Parser Token parseConstructor = do _ <- string "[ctor@" ns <- takeWhile1 (\c -> isAscii c && isAlpha c) _ <- char '.' n <- takeWhile1 isCIdent _ <- char '.' method <- takeWhile1 isCIdent _ <- char ']' return $ SymbolRef $ MethodRef (AbsoluteName ns n) method -- | Parse a reference to a type, of the form -- > [class@Namespace.Name] -- an interface of the form -- > [iface@Namespace.Name] -- or an enum type: -- > [enum@Namespace.Name] -- -- === __Examples__ -- >>> parseOnly (parseClass <* endOfInput) "[class@Gtk.Dialog]" -- Right (SymbolRef (TypeRef (AbsoluteName "Gtk" "Dialog"))) -- -- >>> parseOnly (parseClass <* endOfInput) "[iface@Gtk.Editable]" -- Right (SymbolRef (TypeRef (AbsoluteName "Gtk" "Editable"))) -- -- >>> parseOnly (parseClass <* endOfInput) "[enum@Gtk.SizeRequestMode]" -- Right (SymbolRef (TypeRef (AbsoluteName "Gtk" "SizeRequestMode"))) parseClass :: Parser Token parseClass = do _ <- string "[class@" <|> string "[iface@" <|> string "[enum@" ns <- takeWhile1 (\c -> isAscii c && isAlpha c) _ <- char '.' n <- takeWhile1 isCIdent _ <- char ']' return $ SymbolRef $ TypeRef (AbsoluteName ns n) parseSignal :: Parser Token parseSignal = parseOldSignal <|> parseNewSignal -- | Parse an old style signal name, of the form -- > #Object::signal -- -- === __Examples__ -- >>> parseOnly (parseOldSignal <* endOfInput) "#GtkButton::activate" -- Right (SymbolRef (OldSignalRef "GtkButton" "activate")) parseOldSignal :: Parser Token parseOldSignal = do _ <- char '#' obj <- parseCIdent _ <- string "::" signal <- signalOrPropName return (SymbolRef (OldSignalRef obj signal)) -- | Parse a new style signal ref, of the form -- > [signal@Namespace.Object::signal-name] -- -- === __Examples__ -- >>> parseOnly (parseNewSignal <* endOfInput) "[signal@Gtk.AboutDialog::activate-link]" -- Right (SymbolRef (SignalRef (AbsoluteName "Gtk" "AboutDialog") "activate-link")) parseNewSignal :: Parser Token parseNewSignal = do _ <- string "[signal@" ns <- takeWhile1 (\c -> isAscii c && isAlpha c) _ <- char '.' n <- parseCIdent _ <- string "::" signal <- takeWhile1 (\c -> (isAscii c && isAlpha c) || c == '-') _ <- char ']' return (SymbolRef (SignalRef (AbsoluteName ns n) signal)) -- | Parse a reference to a signal defined in the current module, of the form -- > ::signal -- -- === __Examples__ -- >>> parseOnly (parseLocalSignal <* endOfInput) "::activate" -- Right (SymbolRef (LocalSignalRef "activate")) parseLocalSignal :: Parser Token parseLocalSignal = do _ <- string "::" signal <- signalOrPropName return (SymbolRef (LocalSignalRef signal)) -- | Parse a property name in the old style, of the form -- > #Object:property -- -- === __Examples__ -- >>> parseOnly (parseOldProperty <* endOfInput) "#GtkButton:always-show-image" -- Right (SymbolRef (OldPropertyRef "GtkButton" "always-show-image")) parseOldProperty :: Parser Token parseOldProperty = do _ <- char '#' obj <- parseCIdent _ <- char ':' property <- signalOrPropName return (SymbolRef (OldPropertyRef obj property)) -- | Parse a property name in the new style: -- > [property@Namespace.Object:property-name] -- -- === __Examples__ -- >>> parseOnly (parseNewProperty <* endOfInput) "[property@Gtk.ProgressBar:show-text]" -- Right (SymbolRef (PropertyRef (AbsoluteName "Gtk" "ProgressBar") "show-text")) parseNewProperty :: Parser Token parseNewProperty = do _ <- string "[property@" ns <- takeWhile1 (\c -> isAscii c && isAlpha c) _ <- char '.' n <- parseCIdent _ <- char ':' property <- takeWhile1 (\c -> (isAscii c && isAlpha c) || c == '-') _ <- char ']' return (SymbolRef (PropertyRef (AbsoluteName ns n) property)) -- | Parse a property parseProperty :: Parser Token parseProperty = parseOldProperty <|> parseNewProperty -- | Parse an xml comment, of the form -- > -- Note that this function keeps spaces. -- -- === __Examples__ -- >>> parseOnly (parseComment <* endOfInput) "" -- Right (Comment " comment ") parseComment :: Parser Token parseComment = do comment <- string "") return (Comment $ T.pack comment) -- | Parse an old style reference to a virtual method, of the form -- > #Struct.method() -- -- === __Examples__ -- >>> parseOnly (parseOldVMethod <* endOfInput) "#Foo.bar()" -- Right (SymbolRef (VMethodRef "Foo" "bar")) parseOldVMethod :: Parser Token parseOldVMethod = do _ <- char '#' obj <- parseCIdent _ <- char '.' method <- parseCIdent _ <- string "()" return (SymbolRef (VMethodRef obj method)) -- | Parse a new style reference to a virtual function, of the form -- > [vfunc@Namespace.Object.vfunc_name] -- -- >>> parseOnly (parseVFunc <* endOfInput) "[vfunc@Gtk.Widget.get_request_mode]" -- Right (SymbolRef (VFuncRef (AbsoluteName "Gtk" "Widget") "get_request_mode")) parseVFunc :: Parser Token parseVFunc = do _ <- string "[vfunc@" ns <- takeWhile1 (\c -> isAscii c && isAlpha c) _ <- char '.' n <- parseCIdent _ <- char '.' vfunc <- parseCIdent _ <- char ']' return (SymbolRef (VFuncRef (AbsoluteName ns n) vfunc)) -- | Parse a reference to a virtual method parseVMethod :: Parser Token parseVMethod = parseOldVMethod <|> parseVFunc -- | Parse a reference to a struct field, of the form -- > #Struct.field -- -- === __Examples__ -- >>> parseOnly (parseStructField <* endOfInput) "#Foo.bar" -- Right (SymbolRef (StructFieldRef "Foo" "bar")) parseStructField :: Parser Token parseStructField = do _ <- char '#' obj <- parseCIdent _ <- char '.' field <- parseCIdent return (SymbolRef (StructFieldRef obj field)) -- | Parse a reference to a C type, of the form -- > #Type -- -- === __Examples__ -- >>> parseOnly (parseCType <* endOfInput) "#Foo" -- Right (SymbolRef (CTypeRef "Foo")) parseCType :: Parser Token parseCType = do _ <- char '#' obj <- parseCIdent return (SymbolRef (CTypeRef obj)) -- | Parse a constant, of the form -- > %CONSTANT_NAME -- -- === __Examples__ -- >>> parseOnly (parseConstant <* endOfInput) "%TEST_CONSTANT" -- Right (SymbolRef (ConstantRef "TEST_CONSTANT")) parseConstant :: Parser Token parseConstant = do _ <- char '%' c <- parseCIdent return (SymbolRef (ConstantRef c)) -- | Parse a reference to a parameter, of the form -- > @param_name -- -- === __Examples__ -- >>> parseOnly (parseParam <* endOfInput) "@test_param" -- Right (SymbolRef (ParamRef "test_param")) parseParam :: Parser Token parseParam = do _ <- char '@' param <- parseCIdent return (SymbolRef (ParamRef param)) -- | Name of a signal or property name. Similar to a C identifier, but -- hyphens are allowed too. signalOrPropName :: Parser Text signalOrPropName = takeWhile1 isSignalOrPropIdent where isSignalOrPropIdent :: Char -> Bool isSignalOrPropIdent '-' = True isSignalOrPropIdent c = isCIdent c -- | Parse a escaped special character, i.e. one preceded by '\'. parseEscaped :: Parser Token parseEscaped = do _ <- char '\\' c <- satisfy (`elem` ("#@%\\`" :: [Char])) return $ Literal (T.singleton c) -- | Parse a literal, i.e. anything without a known special -- meaning. Note that this parser always consumes the first character, -- regardless of what it is. parseBoringLiteral :: Parser Token parseBoringLiteral = do c <- anyChar boring <- takeWhile (not . special) return $ Literal (T.cons c boring) -- | List of special characters from the point of view of the parser -- (in the sense that they may be the beginning of something with a -- special interpretation). special :: Char -> Bool special '#' = True special '@' = True special '%' = True special '\\' = True special '`' = True special '|' = True special '[' = True special '!' = True special '\n' = True special ':' = True special c = isCIdent c -- | Parse a verbatim string, of the form -- > `verbatim text` -- -- === __Examples__ -- >>> parseOnly (parseVerbatim <* endOfInput) "`Example quote!`" -- Right (Verbatim "Example quote!") parseVerbatim :: Parser Token parseVerbatim = do _ <- char '`' v <- takeWhile1 (/= '`') _ <- char '`' return $ Verbatim v -- | Parse a URL in Markdown syntax, of the form -- > [name](url) -- -- === __Examples__ -- >>> parseOnly (parseUrl <* endOfInput) "[haskell](http://haskell.org)" -- Right (ExternalLink (Link {linkName = "haskell", linkAddress = "http://haskell.org"})) parseUrl :: Parser Token parseUrl = do _ <- char '[' name <- takeWhile1 (/= ']') _ <- string "](" address <- takeWhile1 (/= ')') _ <- char ')' return $ ExternalLink $ Link {linkName = name, linkAddress = address} -- | Parse an image reference, of the form -- > ![label](url) -- -- === __Examples__ -- >>> parseOnly (parseImage <* endOfInput) "![](diagram.png)" -- Right (Image (Link {linkName = "", linkAddress = "diagram.png"})) parseImage :: Parser Token parseImage = do _ <- string "![" name <- takeWhile (/= ']') _ <- string "](" address <- takeWhile1 (/= ')') _ <- char ')' return $ Image $ Link {linkName = name, linkAddress = address} -- | Parse a code block embedded in the documentation. parseCodeBlock :: Parser Token parseCodeBlock = parseOldStyleCodeBlock <|> parseNewStyleCodeBlock -- | Parse a new style code block, of the form -- > ```c -- > some c code -- > ``` -- -- === __Examples__ -- >>> parseOnly (parseNewStyleCodeBlock <* endOfInput) "```c\nThis is C code\n```" -- Right (CodeBlock (Just (Language "c")) "This is C code") parseNewStyleCodeBlock :: Parser Token parseNewStyleCodeBlock = do _ <- string "```" lang <- T.strip <$> takeWhile (/= '\n') _ <- char '\n' let maybeLang = if T.null lang then Nothing else Just lang code <- T.pack <$> manyTill anyChar (string "\n```") return $ CodeBlock (Language <$> maybeLang) code -- | Parse an old style code block, of the form -- > |[ code ]| -- -- === __Examples__ -- >>> parseOnly (parseOldStyleCodeBlock <* endOfInput) "|[this is code]|" -- Right (CodeBlock Nothing "this is code") -- -- >>> parseOnly (parseOldStyleCodeBlock <* endOfInput) "|[this is C code]|" -- Right (CodeBlock (Just (Language "C")) "this is C code") parseOldStyleCodeBlock :: Parser Token parseOldStyleCodeBlock = do _ <- string "|[" lang <- (Just <$> parseLanguage) <|> return Nothing code <- T.pack <$> manyTill anyChar (string "]|") return $ CodeBlock lang code -- | Parse the language of a code block, specified as a comment. parseLanguage :: Parser Language parseLanguage = do _ <- string "" return $ Language lang -- | Parse a section header, given by a number of hash symbols, and -- then ordinary text. Note that this parser "eats" the newline before -- and after the section header. parseSectionHeader :: Parser Token parseSectionHeader = char '\n' >> parseInitialSectionHeader -- | Parse a section header at the beginning of the text. I.e. this is -- the same as `parseSectionHeader`, but we do not expect a newline as -- a first character. -- -- === __Examples__ -- >>> parseOnly (parseInitialSectionHeader <* endOfInput) "### Hello! ###\n" -- Right (SectionHeader 3 (GtkDoc [Literal "Hello! "])) -- -- >>> parseOnly (parseInitialSectionHeader <* endOfInput) "# Hello!\n" -- Right (SectionHeader 1 (GtkDoc [Literal "Hello!"])) parseInitialSectionHeader :: Parser Token parseInitialSectionHeader = do hashes <- takeWhile1 (== '#') _ <- many1 space heading <- takeWhile1 (notInClass "#\n") _ <- (string hashes >> char '\n') <|> (char '\n') return $ SectionHeader (T.length hashes) (parseGtkDoc heading) -- | Parse a list header. Note that the newline before the start of -- the list is "eaten" by this parser, but is restored later by -- `parseGtkDoc`. -- -- === __Examples__ -- >>> parseOnly (parseList <* endOfInput) "\n- First item\n- Second item" -- Right (List [ListItem (GtkDoc [Literal "First item"]) [],ListItem (GtkDoc [Literal "Second item"]) []]) -- -- >>> parseOnly (parseList <* endOfInput) "\n\n- Two line\n item\n\n- Second item,\n also two lines" -- Right (List [ListItem (GtkDoc [Literal "Two line"]) [GtkDoc [Literal "item"]],ListItem (GtkDoc [Literal "Second item,"]) [GtkDoc [Literal "also two lines"]]]) parseList :: Parser Token parseList = do items <- many1 parseListItem return $ List items where parseListItem :: Parser ListItem parseListItem = do _ <- char '\n' _ <- string "\n- " <|> string "- " first <- takeWhile1 (/= '\n') rest <- many' parseLine return $ ListItem (parseGtkDoc first) (map parseGtkDoc rest) parseLine :: Parser Text parseLine = string "\n " >> takeWhile1 (/= '\n') -- | Turn an ordinary `Name` into a `DocSymbolName` docName :: Name -> DocSymbolName docName (Name ns n) = AbsoluteName ns n -- | Return a `Name` from a potentially relative `DocSymbolName`, -- using the provided default namespace if the name is relative. resolveDocSymbol :: DocSymbolName -> Text -> Name resolveDocSymbol (AbsoluteName ns n) _ = Name ns n resolveDocSymbol (RelativeName n) defaultNS = Name defaultNS n haskell-gi-0.26.12/lib/Data/GI/CodeGen/Haddock.hs0000644000000000000000000003331107346545000017207 0ustar0000000000000000-- | Render an abstract representation of documentation (as produced -- by `parseGtkDoc`) as Haddock formatted documentation. module Data.GI.CodeGen.Haddock ( deprecatedPragma , writeDocumentation , RelativeDocPosition(..) , writeHaddock , writeArgDocumentation , writeReturnDocumentation , addSectionDocumentation ) where #if !MIN_VERSION_base(4,13,0) import Control.Monad (mapM_, unless) #else import Control.Monad (unless) #endif import qualified Data.Map as M #if !MIN_VERSION_base(4,11,0) import Data.Monoid ((<>)) #endif import qualified Data.Text as T import Data.Text (Text) import Data.GI.GIR.Arg (Arg(..)) import Data.GI.GIR.BasicTypes (Name(Name)) import Data.GI.GIR.Callable (Callable(..)) import Data.GI.GIR.Deprecation (DeprecationInfo(..)) import Data.GI.GIR.Documentation (Documentation(..)) import Data.GI.CodeGen.Code (CodeGen, config, line, HaddockSection, getC2HMap, addSectionFormattedDocs) import Data.GI.CodeGen.Config (modName, overrides) import Data.GI.CodeGen.CtoHaskellMap (Hyperlink(..)) import Data.GI.CodeGen.GtkDoc (GtkDoc(..), Token(..), CRef(..), Language(..), Link(..), ListItem(..), parseGtkDoc, DocSymbolName(..), resolveDocSymbol, docName) import Data.GI.CodeGen.Overrides (onlineDocsMap) import Data.GI.CodeGen.SymbolNaming (lowerSymbol, signalHaskellName, haddockSignalAnchor) -- | Where is the documentation located with respect to the relevant -- symbol, useful for determining whether we want to start with @|@ or @^@. data RelativeDocPosition = DocBeforeSymbol | DocAfterSymbol -- | Given a `GtkDoc`, a map from C identifiers to Haskell symbols, -- and a location online where to find the C documentation, render the -- corresponding Haddock-formatted text. Note that the comment -- delimiters are not included in the output. -- -- === __Examples__ -- >>> formatHaddock M.empty "" "Test" (GtkDoc [Literal "Hello ", Literal "World!"]) -- "Hello World!" -- -- >>> let c2h = M.fromList [(OldFunctionRef "foo", ValueIdentifier "foo")] -- >>> formatHaddock c2h "" "Test" (GtkDoc [SymbolRef (OldFunctionRef "foo")]) -- "'foo'" -- -- >>> let onlineDocs = "http://wiki.haskell.org" -- >>> formatHaddock M.empty onlineDocs "Test" (GtkDoc [ExternalLink (Link "GI" "GObjectIntrospection")]) -- "" -- -- >>> formatHaddock M.empty "a" "Test" (GtkDoc [List [ListItem (GtkDoc [Image (Link "test" "test.png")]) []]]) -- "\n* <>\n" formatHaddock :: M.Map CRef Hyperlink -> Text -> Text -> GtkDoc -> Text formatHaddock c2h docBase defaultNS (GtkDoc tokens) = T.concat $ map formatToken tokens where formatToken :: Token -> Text formatToken (Literal l) = escape l formatToken (Comment _) = "" formatToken (Verbatim v) = "@" <> escape v <> "@" formatToken (CodeBlock l c) = formatCodeBlock l c formatToken (ExternalLink l) = formatLink l docBase formatToken (Image l) = formatImage l docBase formatToken (SectionHeader l h) = formatSectionHeader c2h docBase defaultNS l h formatToken (List l) = formatList c2h docBase defaultNS l formatToken (SymbolRef cr) = case M.lookup cr c2h of Just hr -> formatHyperlink hr Nothing -> formatUnknownCRef c2h defaultNS cr -- | Format a `CRef` whose Haskell representation is not known, using -- a provided default namespace for relative symbols. formatUnknownCRef :: M.Map CRef Hyperlink -> Text -> CRef -> Text formatUnknownCRef _ _ (OldFunctionRef f) = formatCRef $ f <> "()" formatUnknownCRef _ defaultNS (FunctionRef n) = formatCRef $ formatDocSymbol n defaultNS formatUnknownCRef _ _ (ParamRef p) = "/@" <> lowerSymbol p <> "@/" formatUnknownCRef _ _ (LocalSignalRef s) = let sn = signalHaskellName s in "[" <> sn <> "](#" <> haddockSignalAnchor <> sn <> ")" formatUnknownCRef c2h defaultNS (SignalRef docSymbol signal) = let owner@(Name ns n) = resolveDocSymbol docSymbol defaultNS in case M.lookup (TypeRef (docName owner)) c2h of Nothing -> formatCRef $ ns <> "." <> n <> "::" <> signal Just r -> formatHyperlink r <> "::" <> formatCRef signal formatUnknownCRef c2h _ (OldSignalRef owner signal) = case M.lookup (CTypeRef owner) c2h of Nothing -> formatCRef $ owner <> "::" <> signal Just r -> formatHyperlink r <> "::" <> formatCRef signal formatUnknownCRef c2h _ (OldPropertyRef owner prop) = case M.lookup (CTypeRef owner) c2h of Nothing -> formatCRef $ owner <> ":" <> prop Just r -> formatHyperlink r <> ":" <> formatCRef prop formatUnknownCRef c2h defaultNS (PropertyRef docSymbol prop) = let owner@(Name ns n) = resolveDocSymbol docSymbol defaultNS in case M.lookup (TypeRef (docName owner)) c2h of Nothing -> formatCRef $ ns <> "." <> n <> ":" <> prop Just r -> formatHyperlink r <> ":" <> formatCRef prop formatUnknownCRef c2h _ (VMethodRef owner vmethod) = case M.lookup (CTypeRef owner) c2h of Nothing -> formatCRef $ owner <> "." <> vmethod <> "()" Just r -> formatHyperlink r <> "." <> formatCRef vmethod <> "()" formatUnknownCRef c2h defaultNS (VFuncRef docSymbol vmethod) = let owner@(Name ns n) = resolveDocSymbol docSymbol defaultNS in case M.lookup (TypeRef (docName owner)) c2h of Nothing -> formatCRef $ ns <> "." <> n <> "." <> vmethod <> "()" Just r -> formatHyperlink r <> "." <> formatCRef vmethod <> "()" formatUnknownCRef c2h defaultNS(MethodRef docSymbol method) = let owner@(Name ns n) = resolveDocSymbol docSymbol defaultNS in case M.lookup (TypeRef (docName owner)) c2h of Nothing -> formatCRef $ ns <> "." <> n <> "." <> method <> "()" Just r -> formatHyperlink r <> "." <> formatCRef method <> "()" formatUnknownCRef c2h _ (StructFieldRef owner field) = case M.lookup (CTypeRef owner) c2h of Nothing -> formatCRef $ owner <> "." <> field Just r -> formatHyperlink r <> "." <> formatCRef field formatUnknownCRef _ _ (CTypeRef t) = formatCRef t formatUnknownCRef _ defaultNS (TypeRef n) = formatCRef $ formatDocSymbol n defaultNS formatUnknownCRef _ _ (ConstantRef t) = formatCRef t -- | Format the given symbol name in a fully qualified way, using the -- default namespace if needed. formatDocSymbol :: DocSymbolName -> Text -> Text formatDocSymbol (RelativeName n) defaultNS = defaultNS <> "." <> n formatDocSymbol (AbsoluteName ns n) _ = ns <> "." <> n -- | Formatting for an unknown C reference. formatCRef :: Text -> Text formatCRef t = "@/" <> escape t <> "/@" -- | Format a `Hyperlink` into plain `Text`. formatHyperlink :: Hyperlink -> Text formatHyperlink (TypeIdentifier t) = "t'" <> t <> "'" formatHyperlink (ValueIdentifier t) = "'" <> t <> "'" formatHyperlink (ModuleLink m) = "\"" <> m <> "\"" formatHyperlink (ModuleLinkWithAnchor mLabel m a) = case mLabel of Nothing -> "\"" <> m <> "#" <> a <> "\"" Just label -> "[" <> label <> "](\"" <> m <> "#" <> a <> "\")" -- | Format a code block in a specified language. formatCodeBlock :: Maybe Language -> Text -> Text formatCodeBlock maybeLang code = let header = case maybeLang of Nothing -> "" Just (Language lang) -> "\n=== /" <> lang <> " code/\n" birdTrack = T.unlines . map (T.cons '>') . T.lines in header <> birdTrack code -- | Qualify the given address with the docBase, if it is not an -- absolute address. qualifiedWith :: Text -> Text -> Text qualifiedWith address docBase = if "http://" `T.isPrefixOf` address || "https://" `T.isPrefixOf` address then address else if "/" `T.isSuffixOf` docBase then docBase <> address else docBase <> "/" <> address -- | Format a link to some external resource. formatLink :: Link -> Text -> Text formatLink (Link {linkName = name, linkAddress = address}) docBase = let address' = address `qualifiedWith` docBase name' = T.replace ">" "\\>" name in "<" <> address' <> " " <> name' <> ">" -- | Format an embedded image. formatImage :: Link -> Text -> Text formatImage (Link {linkName = name, linkAddress = address}) docBase = let address' = address `qualifiedWith` docBase name' = T.replace ">" "\\>" name in if T.null name' then "<<" <> address' <> ">>" else "<<" <> address' <> " " <> name' <> ">>" -- | Format a section header of the given level and with the given -- text. Note that the level will be truncated to 2, if it is larger -- than that. formatSectionHeader :: M.Map CRef Hyperlink -> Text -> Text -> Int -> GtkDoc -> Text formatSectionHeader c2h docBase defaultNS level header = T.replicate level "=" <> " " <> formatHaddock c2h docBase defaultNS header <> "\n" -- | Format a list of items. formatList :: M.Map CRef Hyperlink -> Text -> Text -> [ListItem] -> Text formatList c2h docBase defaultNS items = "\n" <> T.concat (map formatListItem items) where formatListItem :: ListItem -> Text formatListItem (ListItem first rest) = "* " <> format first <> "\n" <> T.concat (map ((<> "\n") . format) rest) format :: GtkDoc -> Text format doc = formatHaddock c2h docBase defaultNS doc -- | Escape the reserved Haddock characters in a given `Text`. -- -- === __Examples__ -- >>> escape "\"" -- "\\\"" -- -- >>> escape "foo@bar.com" -- "foo\\@bar.com" -- -- >>> escape "C:\\Applications" -- "C:\\\\Applications" escape :: Text -> Text escape = T.concatMap escapeChar where escapeChar :: Char -> Text escapeChar c = if c `elem` ("\\/'`\"@<" :: [Char]) then "\\" <> T.singleton c else T.singleton c -- | Get the base url for the online C language documentation for the -- module being currently generated. getDocBase :: CodeGen e Text getDocBase = do mod <- modName <$> config docsMap <- (onlineDocsMap . overrides) <$> config return $ case M.lookup mod docsMap of Just url -> url Nothing -> "http://developer.gnome.org/" <> T.toLower mod <> "/stable" -- | Write the deprecation pragma for the given `DeprecationInfo`, if -- not `Nothing`. deprecatedPragma :: Text -> Maybe DeprecationInfo -> CodeGen e () deprecatedPragma _ Nothing = return () deprecatedPragma name (Just info) = do c2h <- getC2HMap docBase <- getDocBase defaultNS <- modName <$> config line $ "{-# DEPRECATED " <> name <> " " <> (T.pack . show) (note <> reason c2h docBase defaultNS) <> " #-}" where reason c2h docBase defaultNS = case deprecationMessage info of Nothing -> [] Just msg -> map (formatHaddock c2h docBase defaultNS . parseGtkDoc) (T.lines msg) note = case deprecatedSinceVersion info of Nothing -> [] Just v -> ["(Since version " <> v <> ")"] -- | Format the given documentation into a set of lines. Note that -- this does include the opening or ending comment delimiters. formatDocumentation :: M.Map CRef Hyperlink -> Text -> Text -> Documentation -> Text formatDocumentation c2h docBase defaultNS doc = do let description = case rawDocText doc of Just raw -> formatHaddock c2h docBase defaultNS (parseGtkDoc raw) Nothing -> "/No description available in the introspection data./" description <> case sinceVersion doc of Nothing -> "" Just ver -> "\n\n/Since: " <> ver <> "/" -- | Write the given documentation into generated code. writeDocumentation :: RelativeDocPosition -> Documentation -> CodeGen e () writeDocumentation pos doc = do c2h <- getC2HMap docBase <- getDocBase defaultNS <- modName <$> config writeHaddock pos (formatDocumentation c2h docBase defaultNS doc) -- | Like `writeDocumentation`, but allows us to pass explicitly the -- Haddock comment to write. writeHaddock :: RelativeDocPosition -> Text -> CodeGen e () writeHaddock pos haddock = let marker = case pos of DocBeforeSymbol -> "|" DocAfterSymbol -> "^" lines = case T.lines haddock of [] -> [] (first:rest) -> ("-- " <> marker <> " " <> first) : map ("-- " <>) rest in mapM_ line lines -- | Write the documentation for the given argument. writeArgDocumentation :: Arg -> CodeGen e () writeArgDocumentation arg = case rawDocText (argDoc arg) of Nothing -> return () Just raw -> do c2h <- getC2HMap docBase <- getDocBase defaultNS <- modName <$> config let haddock = "/@" <> lowerSymbol (argCName arg) <> "@/: " <> formatHaddock c2h docBase defaultNS (parseGtkDoc raw) writeHaddock DocAfterSymbol haddock -- | Write the documentation for the given return value. writeReturnDocumentation :: Callable -> Bool -> CodeGen e () writeReturnDocumentation callable skip = do c2h <- getC2HMap docBase <- getDocBase defaultNS <- modName <$> config let returnValInfo = if skip then [] else case rawDocText (returnDocumentation callable) of Nothing -> [] Just raw -> ["__Returns:__ " <> formatHaddock c2h docBase defaultNS (parseGtkDoc raw)] throwsInfo = if callableThrows callable then ["/(Can throw 'Data.GI.Base.GError.GError')/"] else [] let fullInfo = T.intercalate " " (returnValInfo ++ throwsInfo) unless (T.null fullInfo) $ writeHaddock DocAfterSymbol fullInfo -- | Add the given text to the documentation for the section being generated. addSectionDocumentation :: HaddockSection -> Documentation -> CodeGen e () addSectionDocumentation section doc = do c2h <- getC2HMap docBase <- getDocBase defaultNS <- modName <$> config let formatted = formatDocumentation c2h docBase defaultNS doc addSectionFormattedDocs section formatted haskell-gi-0.26.12/lib/Data/GI/CodeGen/Inheritance.hs0000644000000000000000000001520707346545000020107 0ustar0000000000000000{-# LANGUAGE ScopedTypeVariables #-} module Data.GI.CodeGen.Inheritance ( fullObjectPropertyList , fullInterfacePropertyList , fullObjectSignalList , fullInterfaceSignalList , fullObjectMethodList , fullInterfaceMethodList , instanceTree ) where import Control.Monad (foldM, when) import qualified Data.Map as M #if !MIN_VERSION_base(4,13,0) import Data.Monoid ((<>)) #endif import Data.Text (Text) import Data.GI.CodeGen.API import Data.GI.CodeGen.Code (findAPIByName, CodeGen, line) import Data.GI.CodeGen.Util (tshow) import Data.GI.CodeGen.Fixups (dropMovedItems) -- | 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 e [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 instance Inheritable Method where ifInheritables = ifMethods objInheritables = objMethods iName = name . methodName -- 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 e [(Name, i)] apiInheritables n = do api <- findAPIByName n case dropMovedItems api of Just (APIInterface iface) -> return $ map ((,) n) (ifInheritables iface) Just (APIObject object) -> return $ map ((,) n) (objInheritables object) _ -> error $ "apiInheritables : Unexpected API : " ++ show n fullAPIInheritableList :: Inheritable i => Name -> CodeGen e [(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 e [(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 e [(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 print a warning, and choose to use the -- one closest to the leaves of the object hierarchy. removeDuplicates :: forall i e. (Eq i, Show i, Inheritable i) => Bool -> [(Name, i)] -> CodeGen e [(Name, i)] removeDuplicates verbose inheritables = (filterTainted . M.toList) <$> foldM filterDups M.empty inheritables where filterDups :: M.Map Text (Bool, Name, i) -> (Name, i) -> CodeGen e (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 when verbose $ do line "--- XXX Duplicated object with different types:" line $ " --- " <> tshow n <> " -> " <> tshow p line $ " --- " <> tshow name <> " -> " <> tshow 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) | (_, (_, name, prop)) <- xs] -- | List all properties defined for an object, including those -- defined by its ancestors. fullObjectPropertyList :: Name -> Object -> CodeGen e [(Name, Property)] fullObjectPropertyList n o = fullObjectInheritableList n o >>= removeDuplicates True -- | List all properties defined for an interface, including those -- defined by its prerequisites. fullInterfacePropertyList :: Name -> Interface -> CodeGen e [(Name, Property)] fullInterfacePropertyList n i = fullInterfaceInheritableList n i >>= removeDuplicates True -- | List all signals defined for an object, including those -- defined by its ancestors. fullObjectSignalList :: Name -> Object -> CodeGen e [(Name, Signal)] fullObjectSignalList n o = fullObjectInheritableList n o >>= removeDuplicates True -- | List all signals defined for an interface, including those -- defined by its prerequisites. fullInterfaceSignalList :: Name -> Interface -> CodeGen e [(Name, Signal)] fullInterfaceSignalList n i = fullInterfaceInheritableList n i >>= removeDuplicates True -- | List all methods defined for an object, including those defined -- by its ancestors. fullObjectMethodList :: Name -> Object -> CodeGen e [(Name, Method)] fullObjectMethodList n o = fullObjectInheritableList n o >>= removeDuplicates False -- | List all methods defined for an interface, including those -- defined by its prerequisites. fullInterfaceMethodList :: Name -> Interface -> CodeGen e [(Name, Method)] fullInterfaceMethodList n i = fullInterfaceInheritableList n i >>= removeDuplicates False haskell-gi-0.26.12/lib/Data/GI/CodeGen/LibGIRepository.hs0000644000000000000000000002104407346545000020700 0ustar0000000000000000{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies, DataKinds #-} -- | A minimal wrapper for libgirepository. module Data.GI.CodeGen.LibGIRepository ( girRequire , Typelib , setupTypelibSearchPath , FieldInfo(..) , girStructFieldInfo , girUnionFieldInfo , girLoadGType , girIsSymbolResolvable ) where #if !MIN_VERSION_base(4,8,0) import Control.Applicative ((<$>)) #endif #if !MIN_VERSION_base(4,13,0) import Data.Monoid ((<>)) #endif import Control.Monad (forM, (>=>)) import qualified Data.Map as M import Data.Maybe (isJust) import Data.Text (Text) import qualified Data.Text as T import Foreign.C.Types (CInt(..), CSize(..)) import Foreign.C.String (CString, withCString) import Foreign (nullPtr, Ptr, FunPtr, peek) import System.Environment (lookupEnv) import System.FilePath (searchPathSeparator) import Data.GI.Base.BasicConversions (withTextCString, cstringToText) import Data.GI.Base.BasicTypes (TypedObject(..), GBoxed, GType(..), CGType, ManagedPtr) import Data.GI.Base.GError (GError, checkGError) import Data.GI.Base.ManagedPtr (wrapBoxed, withManagedPtr) import Data.GI.Base.Overloading (HasParentTypes, ParentTypes) import Data.GI.Base.Utils (allocMem, freeMem) import Data.GI.CodeGen.Util (splitOn) -- | Wrapper for 'GIBaseInfo' newtype BaseInfo = BaseInfo (ManagedPtr BaseInfo) -- | Wrapper for 'GITypelib', remembering the originating namespace -- and version. data Typelib = Typelib { typelibNamespace :: Text , typelibVersion :: Text , _typelibPtr :: Ptr Typelib } instance Show Typelib where show t = T.unpack (typelibNamespace t) ++ "-" ++ T.unpack (typelibVersion t) -- | Extra info about a field in a struct or union which is not easily -- determined from the GIR file. (And which we determine by using -- libgirepository.) data FieldInfo = FieldInfo { fieldInfoOffset :: Int } -- | The (empty) set of parent types for `BaseInfo` visible to the -- Haskell type system. instance HasParentTypes BaseInfo type instance ParentTypes BaseInfo = '[] foreign import ccall "g_base_info_gtype_get_type" c_g_base_info_gtype_get_type :: IO GType instance TypedObject BaseInfo where glibType = c_g_base_info_gtype_get_type -- | `BaseInfo`s are registered as boxed in the GLib type system. instance GBoxed BaseInfo foreign import ccall "g_irepository_prepend_search_path" g_irepository_prepend_search_path :: CString -> IO () -- | Add the given directory to the typelib search path, this is a -- thin wrapper over `g_irepository_prepend_search_path`. girPrependSearchPath :: FilePath -> IO () girPrependSearchPath fp = withCString fp g_irepository_prepend_search_path foreign import ccall "g_irepository_require" g_irepository_require :: Ptr () -> CString -> CString -> CInt -> Ptr (Ptr GError) -> IO (Ptr Typelib) -- | A convenience function for setting up the typelib search path -- from the environment. Note that for efficiency reasons this should -- only be called once per program run. If the list of paths passed in -- is empty, the environment variable @HASKELL_GI_TYPELIB_SEARCH_PATH@ -- will be checked. In either case the system directories will be -- searched after the passed in directories. setupTypelibSearchPath :: [FilePath] -> IO () setupTypelibSearchPath [] = do env <- lookupEnv "HASKELL_GI_TYPELIB_SEARCH_PATH" case env of Nothing -> return () Just paths -> mapM_ girPrependSearchPath (splitOn searchPathSeparator paths) setupTypelibSearchPath paths = mapM_ girPrependSearchPath paths -- | 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) (\gerror -> error $ "Could not load typelib for " ++ show ns ++ " version " ++ show version ++ ".\n" ++ "Error was: " ++ show gerror) return (Typelib ns version 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 -- | Get the extra information for the given field. getFieldInfo :: BaseInfo -> IO (Text, FieldInfo) getFieldInfo field = withManagedPtr field $ \fi -> do fname <- (g_base_info_get_name fi >>= cstringToText) fOffset <- g_field_info_get_offset fi return (fname, FieldInfo { fieldInfoOffset = fromIntegral fOffset }) 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. girStructFieldInfo :: Text -> Text -> IO (Int, M.Map Text FieldInfo) girStructFieldInfo 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 fieldInfos <- forM [0..(nfields-1)] (g_struct_info_get_field si >=> wrapBoxed BaseInfo >=> getFieldInfo) return (fromIntegral size, M.fromList fieldInfos) 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. girUnionFieldInfo :: Text -> Text -> IO (Int, M.Map Text FieldInfo) girUnionFieldInfo 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 fieldInfos <- forM [0..(nfields-1)] ( g_union_info_get_field ui >=> wrapBoxed BaseInfo >=> getFieldInfo) return (fromIntegral size, M.fromList fieldInfos) foreign import ccall "g_typelib_symbol" g_typelib_symbol :: Ptr Typelib -> CString -> Ptr (FunPtr a) -> IO CInt -- | Try to load a symbol from the dynamic library associated to the -- given typelib. girLookupSymbol :: forall a. Typelib -> Text -> IO (Maybe (FunPtr a)) girLookupSymbol (Typelib _ _ typelib) symbol = do funPtrPtr <- allocMem :: IO (Ptr (FunPtr a)) result <- withTextCString symbol $ \csymbol -> g_typelib_symbol typelib csymbol funPtrPtr funPtr <- peek funPtrPtr freeMem funPtrPtr if result /= 1 then return Nothing else return (Just funPtr) -- | Load a symbol from the dynamic library associated to the given -- typelib. If the symbol does not exist this will raise an error. girSymbol :: Typelib -> Text -> IO (FunPtr a) girSymbol typelib@(Typelib ns version _) symbol = do maybeSymbol <- girLookupSymbol typelib symbol case maybeSymbol of Just funPtr -> return funPtr Nothing -> error ("Could not resolve symbol " ++ show symbol ++ " in namespace " ++ show (ns <> "-" <> version)) type GTypeInit = IO CGType foreign import ccall "dynamic" gtypeInit :: FunPtr GTypeInit -> GTypeInit -- | Load a GType given the `Typelib` where it lives and the type init -- function. girLoadGType :: Typelib -> Text -> IO GType girLoadGType typelib typeInit = GType <$> (girSymbol typelib typeInit >>= gtypeInit) -- | Check whether a symbol is present in the dynamical liberary. girIsSymbolResolvable :: Typelib -> Text -> IO Bool girIsSymbolResolvable typelib symbol = do maybeSymbol <- girLookupSymbol typelib symbol return (isJust maybeSymbol) haskell-gi-0.26.12/lib/Data/GI/CodeGen/ModulePath.hs0000644000000000000000000000330607346545000017715 0ustar0000000000000000{-# LANGUAGE GeneralizedNewtypeDeriving #-} -- | Abstract representation for paths into modules. module Data.GI.CodeGen.ModulePath ( ModulePath(..) , toModulePath , (/.) , dotModulePath ) where #if !MIN_VERSION_base(4,13,0) import Data.Monoid (Monoid(..), (<>)) #endif import Data.String (IsString(..)) import qualified Data.Text as T import qualified Data.Semigroup as Sem import Data.Text (Text) import Data.GI.CodeGen.Util (ucFirst) -- | A path to a module. newtype ModulePath = ModulePath { modulePathToList :: [Text] } deriving (Sem.Semigroup, Monoid, Eq, Show, Ord) -- | Construct a `ModulePath` from a `String`. instance IsString ModulePath where fromString = toModulePath . T.pack -- | Construct a path into the given GIR namespace. The given `Text` -- will be split along ".". -- -- === __Examples__ -- >>> dotModulePath (toModulePath "Foo") -- "Foo" -- -- >>> dotModulePath ("Foo" <> toModulePath "Bar.Baz") -- "Foo.Bar.Baz" -- -- >>> dotModulePath ("Foo" <> toModulePath "bar.baz") -- "Foo.Bar.Baz" toModulePath :: Text -> ModulePath toModulePath p = ModulePath (map ucFirst (T.split (== '.') p)) -- | Turn a module path into the corresponding dotted string. Note -- that the implementation ensures that the module names start with a -- capital letter. -- -- === __Examples__ -- >>> dotModulePath ("Foo" /. "Bar" /. "Baz") -- "Foo.Bar.Baz" -- -- >>> dotModulePath ("foo" /. "bar" /. "baz") -- "Foo.Bar.Baz" dotModulePath :: ModulePath -> Text dotModulePath (ModulePath mp) = T.intercalate "." mp -- | Append the given component to the given module path. -- -- === __Examples__ -- >>> dotModulePath ("Foo" /. "Bar") -- "Foo.Bar" (/.) :: ModulePath -> Text -> ModulePath (/.) mp p = mp <> toModulePath p haskell-gi-0.26.12/lib/Data/GI/CodeGen/OverloadedMethods.hs0000644000000000000000000002113207346545000021260 0ustar0000000000000000module Data.GI.CodeGen.OverloadedMethods ( genMethodList , genMethodInfo , genUnsupportedMethodInfo ) where import Control.Monad (forM, forM_, when) #if !MIN_VERSION_base(4,11,0) import Data.Monoid ((<>)) #endif import Data.Text (Text) import qualified Data.Text as T import Data.GI.CodeGen.API import Data.GI.CodeGen.Conversions (ExposeClosures(..)) import Data.GI.CodeGen.Callable (callableSignature, Signature(..), ForeignSymbol(..), fixupCallerAllocates) import Data.GI.CodeGen.Code import Data.GI.CodeGen.ModulePath (dotModulePath) import Data.GI.CodeGen.SymbolNaming (lowerName, upperName, qualifiedSymbol, moduleLocation, hackageModuleLink) import Data.GI.CodeGen.Util (ucFirst) -- | Qualified name for the info for a given method. methodInfoName :: Name -> Method -> CodeGen e Text methodInfoName n method = let infoName = upperName n <> (ucFirst . lowerName . methodName) method <> "MethodInfo" in qualifiedSymbol infoName n -- | Appropriate instances so overloaded labels are properly resolved. genMethodResolver :: Text -> CodeGen e () genMethodResolver n = do addLanguagePragma "TypeApplications" group $ do line $ "instance (info ~ Resolve" <> n <> "Method t " <> n <> ", " <> "O.OverloadedMethod info " <> n <> " p) => OL.IsLabel t (" <> n <> " -> p) where" line $ "#if MIN_VERSION_base(4,10,0)" indent $ line $ "fromLabel = O.overloadedMethod @info" line $ "#else" indent $ line $ "fromLabel _ = O.overloadedMethod @info" line $ "#endif" -- The circular instance trick is to avoid the liberal coverage -- condition. We should be using DYSFUNCTIONAL pragmas instead, once -- those are implemented: -- https://github.com/ghc-proposals/ghc-proposals/pull/374 cppIf (CPPMinVersion "base" (4,13,0)) $ group $ do line $ "instance (info ~ Resolve" <> n <> "Method t " <> n <> ", " <> "O.OverloadedMethod info " <> n <> " p, " <> "R.HasField t " <> n <> " p) => " <> "R.HasField t " <> n <> " p where" indent $ line $ "getField = O.overloadedMethod @info" group $ do line $ "instance (info ~ Resolve" <> n <> "Method t " <> n <> ", " <> "O.OverloadedMethodInfo info " <> n <> ") => " <> "OL.IsLabel t (O.MethodProxy info " <> n <> ") where" line $ "#if MIN_VERSION_base(4,10,0)" indent $ line $ "fromLabel = O.MethodProxy" line $ "#else" indent $ line $ "fromLabel _ = O.MethodProxy" line $ "#endif" -- | Generate the `MethodList` instance given the list of methods for -- the given named type. Returns a Haddock comment summarizing the -- list of methods available. genMethodList :: Name -> [(Name, Method)] -> CodeGen e () genMethodList n methods = do let name = upperName n let filteredMethods = filter isOrdinaryMethod methods gets = filter isGet filteredMethods sets = filter isSet filteredMethods others = filter (\m -> not (isSet m || isGet m)) filteredMethods orderedMethods = others ++ gets ++ sets infos <- forM orderedMethods $ \(owner, method) -> do mi <- methodInfoName owner method return ((lowerName . methodName) method, mi) group $ do let resolver = "Resolve" <> name <> "Method" export (Section MethodSection) resolver line $ "type family " <> resolver <> " (t :: Symbol) (o :: DK.Type) :: DK.Type where" indent $ forM_ infos $ \(label, info) -> do line $ resolver <> " \"" <> label <> "\" o = " <> info indent $ line $ resolver <> " l o = O.MethodResolutionFailed l o" genMethodResolver name docs <- methodListDocumentation others gets sets prependSectionFormattedDocs (Section MethodSection) docs where isOrdinaryMethod :: (Name, Method) -> Bool isOrdinaryMethod (_, m) = methodType m == OrdinaryMethod isGet :: (Name, Method) -> Bool isGet (_, m) = "get_" `T.isPrefixOf` (name . methodName) m isSet :: (Name, Method) -> Bool isSet (_, m) = "set_" `T.isPrefixOf` (name . methodName) m -- | Format a haddock comment with the information about available -- methods. methodListDocumentation :: [(Name, Method)] -> [(Name, Method)] -> [(Name, Method)] -> CodeGen e Text methodListDocumentation [] [] [] = return "" methodListDocumentation ordinary getters setters = do ordinaryFormatted <- formatMethods ordinary gettersFormatted <- formatMethods getters settersFormatted <- formatMethods setters return $ "\n\n === __Click to display all available methods, including inherited ones__\n" <> "==== Methods\n" <> ordinaryFormatted <> "\n==== Getters\n" <> gettersFormatted <> "\n==== Setters\n" <> settersFormatted where formatMethods :: [(Name, Method)] -> CodeGen e Text formatMethods [] = return "/None/.\n" formatMethods methods = do qualifiedMethods <- forM methods $ \(owner, m) -> do api <- findAPIByName owner let mn = lowerName (methodName m) return $ "[" <> mn <> "](\"" <> dotModulePath (moduleLocation owner api) <> "#g:method:" <> mn <> "\")" return $ T.intercalate ", " qualifiedMethods <> ".\n" -- | Treat the instance argument of a method as non-null, even if the -- introspection data may say otherwise. Returns the modified -- callable, together with a boolean value indicating where the -- nullability annotation has been erased. nonNullableInstanceArg :: Callable -> (Callable, Bool) nonNullableInstanceArg c = case args c of inst:rest -> (c {args = inst {mayBeNull = False} : rest}, mayBeNull inst) [] -> (c, False) -- | Generate the `MethodInfo` type and instance for the given method. genMethodInfo :: Name -> Method -> ExcCodeGen () genMethodInfo n m = when (methodType m == OrdinaryMethod) $ group $ do api <- findAPIByName n infoName <- methodInfoName n m let (callable, nullableInstance) = nonNullableInstanceArg . fixupCallerAllocates $ methodCallable m sig <- callableSignature callable (KnownForeignSymbol undefined) WithoutClosures bline $ "data " <> infoName let (obj, otherTypes) = case map snd (signatureArgTypes sig) of -- This should not happen, since ordinary methods always -- have the instance as first argument. [] -> error $ "Internal error: too few parameters! " ++ show m (obj':otherTypes') -> (obj', otherTypes') sigConstraint = "signature ~ (" <> T.intercalate " -> " (otherTypes ++ [signatureReturnType sig]) <> ")" hackageLink <- hackageModuleLink n let mn = methodName m mangled = lowerName (mn {name = name n <> "_" <> name mn}) dbgInfo = dotModulePath (moduleLocation n api) <> "." <> mangled group $ do line $ "instance (" <> T.intercalate ", " (sigConstraint : signatureConstraints sig) <> ") => O.OverloadedMethod " <> infoName <> " " <> obj <> " signature where" if nullableInstance then indent $ line $ "overloadedMethod i = " <> mangled <> " (Just i)" else indent $ line $ "overloadedMethod = " <> mangled group $ do line $ "instance O.OverloadedMethodInfo " <> infoName <> " " <> obj <> " where" indent $ do line $ "overloadedMethodInfo = P.Just (O.ResolvedSymbolInfo {" indent $ do line $ "O.resolvedSymbolName = \"" <> dbgInfo <> "\"," line $ "O.resolvedSymbolURL = \"" <> hackageLink <> "#v:" <> mangled <> "\"" line $ "})" export (NamedSubsection MethodSection $ lowerName mn) infoName -- | Generate a method info that is not actually callable, but rather -- gives a type error when trying to use it. genUnsupportedMethodInfo :: Name -> Method -> CodeGen e () genUnsupportedMethodInfo n m = do infoName <- methodInfoName n m line $ "-- XXX: Dummy instance, since code generation failed.\n" <> "-- Please file a bug at http://github.com/haskell-gi/haskell-gi." bline $ "data " <> infoName group $ do line $ "instance (p ~ (), o ~ O.UnsupportedMethodError \"" <> lowerName (methodName m) <> "\" " <> name n <> ") => O.OverloadedMethod " <> infoName <> " o p where" indent $ line $ "overloadedMethod = undefined" group $ do line $ "instance (o ~ O.UnsupportedMethodError \"" <> lowerName (methodName m) <> "\" " <> name n <> ") => O.OverloadedMethodInfo " <> infoName <> " o where" indent $ line $ "overloadedMethodInfo = undefined" export ToplevelSection infoName haskell-gi-0.26.12/lib/Data/GI/CodeGen/OverloadedSignals.hs0000644000000000000000000000410707346545000021260 0ustar0000000000000000module Data.GI.CodeGen.OverloadedSignals ( genObjectSignals , genInterfaceSignals ) where #if !MIN_VERSION_base(4,8,0) import Control.Applicative ((<$>)) #endif import Control.Monad (when) #if !MIN_VERSION_base(4,11,0) import Data.Monoid ((<>)) #endif import qualified Data.Text as T import Data.GI.CodeGen.API import Data.GI.CodeGen.Code import Data.GI.CodeGen.Inheritance (fullObjectSignalList, fullInterfaceSignalList) import Data.GI.CodeGen.GObject (apiIsGObject) import Data.GI.CodeGen.SymbolNaming (upperName, hyphensToCamelCase, signalInfoName) import Data.GI.CodeGen.Util (lcFirst) -- | Signal instances for (GObject-derived) objects. genObjectSignals :: Name -> Object -> CodeGen e () genObjectSignals n o = do let name = upperName n isGO <- apiIsGObject n (APIObject o) when isGO $ do infos <- fullObjectSignalList n o >>= mapM (\(owner, signal) -> do si <- signalInfoName owner signal return $ "'(\"" <> (lcFirst . hyphensToCamelCase . sigName) signal <> "\", " <> si <> ")") group $ do let signalListType = name <> "SignalList" line $ "type instance O.SignalList " <> name <> " = " <> signalListType line $ "type " <> signalListType <> " = ('[ " <> T.intercalate ", " infos <> "] :: [(Symbol, DK.Type)])" -- | Signal instances for interfaces. genInterfaceSignals :: Name -> Interface -> CodeGen e () genInterfaceSignals n iface = do let name = upperName n infos <- fullInterfaceSignalList n iface >>= mapM (\(owner, signal) -> do si <- signalInfoName owner signal return $ "'(\"" <> (lcFirst . hyphensToCamelCase . sigName) signal <> "\", " <> si <> ")") group $ do let signalListType = name <> "SignalList" line $ "type instance O.SignalList " <> name <> " = " <> signalListType line $ "type " <> signalListType <> " = ('[ " <> T.intercalate ", " infos <> "] :: [(Symbol, DK.Type)])" haskell-gi-0.26.12/lib/Data/GI/CodeGen/Overrides.hs0000644000000000000000000005157707346545000017632 0ustar0000000000000000{-# LANGUAGE ViewPatterns #-} module Data.GI.CodeGen.Overrides ( Overrides(pkgConfigMap, cabalPkgVersion, nsChooseVersion, girFixups, onlineDocsMap) , parseOverrides , filterAPIsAndDeps ) where #if !MIN_VERSION_base(4,8,0) import Control.Applicative ((<$>)) import Data.Traversable (traverse) #endif #if MIN_VERSION_base(4,18,0) import Control.Monad (foldM) #endif import Control.Monad.Except import Control.Monad.State import Control.Monad.Writer (WriterT, execWriterT, tell) import Data.Maybe (isJust) import qualified Data.Map as M import Data.Semigroup as Sem import qualified Data.Set as S import qualified Data.Text as T import Data.Text (Text) import qualified Data.Version as V import Text.ParserCombinators.ReadP (readP_to_S) import qualified System.Info as SI import Data.GI.CodeGen.API import qualified Text.XML as XML import Data.GI.CodeGen.PkgConfig (tryPkgConfig) import Data.GI.CodeGen.Util (tshow, utf8ReadFile) import Data.GI.GIR.XMLUtils (xmlLocalName, xmlNSName, GIRXMLNamespace(CGIRNS, GLibGIRNS, CoreGIRNS)) data Overrides = Overrides { -- | 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, -- | Explicit calloc\/copy\/free for structs/unions. allocInfo :: M.Map Name AllocationInfo, -- | 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 Text Text, -- | Fixups for the GIR data. girFixups :: [GIRRule], -- | Known places where to find the C docs. onlineDocsMap :: M.Map Text Text } deriving (Show) -- | Construct the generic config for a module. defaultOverrides :: Overrides defaultOverrides = Overrides { ignoredElems = M.empty, ignoredAPIs = S.empty, sealedStructs = S.empty, allocInfo = M.empty, pkgConfigMap = M.empty, cabalPkgVersion = Nothing, nsChooseVersion = M.empty, girFixups = [], onlineDocsMap = 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 #if !MIN_VERSION_base(4,11,0) mappend = concatOverrides #endif -- | 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 Sem.Semigroup Overrides where (<>) = concatOverrides -- | Addition of overrides is meaningful. concatOverrides :: Overrides -> Overrides -> Overrides concatOverrides a b = Overrides { ignoredAPIs = ignoredAPIs a <> ignoredAPIs b, sealedStructs = sealedStructs a <> sealedStructs b, allocInfo = allocInfo a <> allocInfo 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, girFixups = girFixups a <> girFixups b, onlineDocsMap = onlineDocsMap a <> onlineDocsMap b } -- | The state of the overrides parser. data ParserState = ParserState { currentNS :: Maybe Text -- ^ The current namespace. , flags :: [Bool] -- ^ The contents of the override file will -- be ignored if there is any `False` value -- here. @if@ primitive push (prepend) -- values here, @endif@ pop them. } deriving (Show) -- | Default, empty, parser state. emptyParserState :: ParserState emptyParserState = ParserState { currentNS = Nothing , flags = [] } -- | Get the current namespace. getNS :: Parser (Maybe Text) getNS = currentNS <$> get -- | Run the given parser only if the flags can be satisfied. withFlags :: Parser () -> Parser () withFlags p = do fs <- flags <$> get if and fs then p else return () -- | We have a bit of context (the current namespace), and can fail, -- encode this in a monad. type Parser a = WriterT Overrides (StateT ParserState (ExceptT Text IO)) a -- | Parse the given overrides, filling in the configuration as -- needed. In case the parsing fails we return a description of the -- error instead. parseOverrides :: Text -> IO (Either Text Overrides) parseOverrides overrides = do runExceptT $ flip evalStateT emptyParserState $ execWriterT $ mapM (parseOneLine . T.strip) (T.lines overrides) -- | 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) = withFlags $ modify' (\s -> s {currentNS = (Just . T.strip) ns}) parseOneLine (T.stripPrefix "ignore " -> Just ign) = withFlags $ getNS >>= parseIgnore ign parseOneLine (T.stripPrefix "seal " -> Just s) = withFlags $ getNS >>= parseSeal s parseOneLine (T.stripPrefix "alloc-info " -> Just s) = withFlags $ getNS >>= parseAllocInfo s parseOneLine (T.stripPrefix "pkg-config-name " -> Just s) = withFlags $ parsePkgConfigName s parseOneLine (T.stripPrefix "cabal-pkg-version " -> Just s) = withFlags $ parseCabalPkgVersion s parseOneLine (T.stripPrefix "namespace-version " -> Just s) = withFlags $ parseNsVersion s parseOneLine (T.stripPrefix "set-attr " -> Just s) = withFlags $ parseSetAttr s parseOneLine (T.stripPrefix "delete-attr " -> Just s) = withFlags $ parseDeleteAttr s parseOneLine (T.stripPrefix "add-node " -> Just s) = withFlags $ parseAdd s parseOneLine (T.stripPrefix "delete-node " -> Just s) = withFlags $ parseDelete s parseOneLine (T.stripPrefix "C-docs-url " -> Just u) = withFlags $ parseDocsUrl u parseOneLine (T.stripPrefix "if " -> Just s) = parseIf s parseOneLine (T.stripPrefix "endif" -> Just s) = parseEndif s parseOneLine (T.stripPrefix "include " -> Just s) = parseInclude s parseOneLine l = throwError $ "Could not understand \"" <> l <> "\"." -- | Ignored elements. parseIgnore :: Text -> Maybe Text -> 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 api) (S.singleton elem)} parseIgnore (T.words -> [T.splitOn "." -> [api]]) (Just ns) = tell $ defaultOverrides {ignoredAPIs = S.singleton (Name ns api)} parseIgnore ignore _ = throwError ("Ignore syntax is of the form \"ignore API.elem\" with '.elem' optional.\nGot \"ignore " <> ignore <> "\" instead.") -- | Sealed structures. parseSeal :: Text -> Maybe Text -> 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 s)} parseSeal seal _ = throwError ("seal syntax is of the form \"seal name\".\nGot \"seal " <> seal <> "\" instead.") -- | Explicit allocation info for wrapped pointers. parseAllocInfo :: Text -> Maybe Text -> Parser () parseAllocInfo _ Nothing = throwError "'alloc-info' requires a namespace to be defined first." parseAllocInfo (T.words -> (n:ops)) (Just ns) = do parsedOps <- traverse parseKeyValuePair ops info <- foldM applyOp unknownAllocationInfo parsedOps tell $ defaultOverrides {allocInfo = M.singleton (Name ns n) info} where applyOp :: AllocationInfo -> (Text, Text) -> Parser AllocationInfo applyOp a ("calloc", f) = return (a {allocCalloc = AllocationOp f}) applyOp a ("copy", f) = return (a {allocCopy = AllocationOp f}) applyOp a ("free", f) = return (a {allocFree = AllocationOp f}) applyOp _ (op, _) = throwError ("Unknown alloc op \"" <> op <> "\".") parseAllocInfo info _ = throwError ("alloc-info syntax is of the form " <> "\"alloc-info name calloc copy free\", with \"-\" meaning " <> "a masked operation. Got \"alloc-info " <> info <> "\" instead.") -- | Parse a explicit key=value pair into a (key, value) tuple. parseKeyValuePair :: Text -> Parser (Text, Text) parseKeyValuePair p = case T.splitOn "=" p of [k,v] -> return (k, v) _ -> throwError ("Could not parse \"" <> p <> "\"as a \"key=value\" pair.") -- | 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 ns 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.") -- | Set a given attribute in the GIR file. parseSetAttr :: Text -> Parser () parseSetAttr (T.words -> [path, attr, newVal]) = do pathSpec <- parsePathSpec path parsedAttr <- parseXMLName attr tell $ defaultOverrides {girFixups = [GIRSetAttr (pathSpec, parsedAttr) newVal]} parseSetAttr t = throwError ("set-attr syntax is of the form\n" <> "\t\"set-attr nodePath attrName newValue\"\n" <> "Got \"set-attr " <> t <> "\" instead.") -- | Delete the given attribute parseDeleteAttr :: Text -> Parser () parseDeleteAttr (T.words -> [path, attr]) = do pathSpec <- parsePathSpec path parsedAttr <- parseXMLName attr tell $ defaultOverrides {girFixups = [GIRDeleteAttr pathSpec parsedAttr]} parseDeleteAttr t = throwError ("delete-attr syntax is of the form\n" <> "\t\"delete-attr nodePath attrName\"\n" <> "Got \"delete-attr " <> t <> "\" instead.") -- | Add the given child node to all nodes matching the path. parseAdd :: Text -> Parser () parseAdd (T.words -> [path, name]) = do pathSpec <- parsePathSpec path parsedName <- parseXMLName name tell $ defaultOverrides {girFixups = [GIRAddNode pathSpec parsedName]} parseAdd t = throwError ("add-node syntax is of the form\n" <> "\t\"add-node nodePath newName\"\n" <> "Got \"add-node " <> t <> "\" instead.") -- | Delete all nodes matching the given path. parseDelete :: Text -> Parser () parseDelete (T.words -> [path]) = do pathSpec <- parsePathSpec path tell $ defaultOverrides {girFixups = [GIRDeleteNode pathSpec]} parseDelete t = throwError ("delete-node syntax is of the form\n" <> "\t\"delete-node nodePath\"\n" <> "Got \"delete-node " <> t <> "\" instead.") -- | Parse a documentation URL for the given module. parseDocsUrl :: Text -> Parser () parseDocsUrl (T.words -> [ns, url]) = do tell $ defaultOverrides { onlineDocsMap = M.singleton ns url } parseDocsUrl t = throwError ("C-docs-url syntax of of the form\n" <> "\t\"C-docs-url namespace url\"\n" <> "Got \"C-docs-url " <> t <> "\" instead.") -- | Parse a path specification, which is of the form -- "nodeSpec1/nodeSpec2/../nodeSpecN", where nodeSpec is a node -- specification of the form "nodeType[:name attribute]". parsePathSpec :: Text -> Parser GIRPath parsePathSpec spec = mapM parseNodeSpec (T.splitOn "/" spec) -- | A specification of a name, which is either a regex (prefixed with -- "~") or a plain name. parseGIRNameTag :: Text -> GIRNameTag parseGIRNameTag (T.stripPrefix "~" -> Just regex) = GIRRegex regex parseGIRNameTag t = GIRPlainName t -- | Parse a single node specification. parseNodeSpec :: Text -> Parser GIRNodeSpec parseNodeSpec spec = case T.splitOn "@" spec of [n] -> return (GIRNamed (parseGIRNameTag n)) ["", t] -> return (GIRType t) [n, t] -> return (GIRTypedName t (parseGIRNameTag n)) _ -> throwError ("Could not understand node spec \"" <> spec <> "\".") -- | Parse an XML name, with an optional prefix. parseXMLName :: Text -> Parser XML.Name parseXMLName a = case T.splitOn ":" a of [n] -> return (xmlLocalName n) ["c", n] -> return (xmlNSName CGIRNS n) ["glib", n] -> return (xmlNSName GLibGIRNS n) ["core", n] -> return (xmlNSName CoreGIRNS n) _ -> throwError ("Could not understand xml name \"" <> a <> "\".") -- | Known operating systems. data OSType = Linux | OSX | Windows deriving (Show) -- | Check whether we are running under the given OS. checkOS :: String -> Parser Bool checkOS os = return (SI.os == os) -- | Parse a textual representation of a version into a `Data.Version.Version`. parseVersion :: Text -> Parser V.Version parseVersion v = (chooseFullParse . readP_to_S V.parseVersion . T.unpack) v where chooseFullParse :: [(V.Version, String)] -> Parser V.Version chooseFullParse [] = throwError ("Could not parse version \"" <> v <> "\".") chooseFullParse [(parsed, "")] = return parsed chooseFullParse (_ : rest) = chooseFullParse rest -- | Check that the given pkg-config package has a version compatible -- with the given constraint. checkPkgConfigVersion :: Text -> Text -> Text -> Parser Bool checkPkgConfigVersion pkg op tVersion = do version <- parseVersion tVersion pcVersion <- liftIO (tryPkgConfig pkg) >>= \case Nothing -> throwError ("Could not determine pkg-config version for \"" <> pkg <> "\".") Just (_, tv) -> parseVersion tv case op of "==" -> return (pcVersion == version) "/=" -> return (pcVersion /= version) ">=" -> return (pcVersion >= version) ">" -> return (pcVersion > version) "<=" -> return (pcVersion <= version) "<" -> return (pcVersion < version) _ -> throwError ("Unrecognized comparison operator \"" <> op <> "\".") -- | Parse a 'if' directive. parseIf :: Text -> Parser () parseIf cond = case T.words cond of [] -> throwError ("Empty 'if' condition.") ["linux"] -> checkOS "linux" >>= setFlag ["osx"] -> checkOS "darwin" >>= setFlag ["windows"] -> checkOS "mingw32" >>= setFlag ("pkg-config-version" : rest) -> case rest of [pkg, op, version] -> checkPkgConfigVersion pkg op version >>= setFlag _ -> throwError ("Syntax for `pkg-config-version' is " <> "\"pkg op version\", got \"" <> tshow rest <> "\".") _ -> throwError ("Unknown condition \"" <> cond <> "\".") where setFlag :: Bool -> Parser () setFlag flag = modify' (\s -> s {flags = flag : flags s}) -- | Parse an 'endif' directive. parseEndif :: Text -> Parser () parseEndif rest = case T.words rest of [] -> unsetFlag _ -> throwError ("Unexpected argument to 'endif': \"" <> rest <> "\".") where unsetFlag :: Parser () unsetFlag = do s <- get case flags s of _:rest -> put (s {flags = rest}) [] -> throwError ("'endif' with no matching 'if'.") -- | Parse the given overrides file, and merge into the given context. parseInclude :: Text -> Parser () parseInclude fname = do includeText <- liftIO $ utf8ReadFile (T.unpack fname) liftIO (parseOverrides includeText) >>= \case Left err -> throwError ("Error when parsing included '" <> fname <> "': " <> err) Right ovs -> tell ovs -- | Filter a set of named objects based on a lookup list of names to -- ignore. filterMethods :: [Method] -> S.Set Text -> [Method] filterMethods set ignores = filter ((`S.notMember` ignores) . name . methodName) set -- | Given the previous allocation info, and a new allocation info, -- replace those entries in the old allocation info which are -- specified in the new info. filterAllocInfo :: AllocationInfo -> AllocationInfo -> AllocationInfo filterAllocInfo old new = AllocationInfo { allocCalloc = replace (allocCalloc old) (allocCalloc new) , allocCopy = replace (allocCopy old) (allocCopy new) , allocFree = replace (allocFree old) (allocFree new) } where replace :: AllocationOp -> AllocationOp -> AllocationOp replace o AllocationOpUnknown = o replace _ o = o -- | Filter one API according to the given config. filterOneAPI :: Overrides -> (Name, API, Maybe (S.Set Text)) -> (Name, API) filterOneAPI ovs (n, APIStruct s, maybeIgnores) = (n, APIStruct s { structMethods = maybe (structMethods s) (filterMethods (structMethods s)) maybeIgnores , structFields = if n `S.member` sealedStructs ovs then [] else structFields s , structAllocationInfo = let ai = structAllocationInfo s in case M.lookup n (allocInfo ovs) of Just info -> filterAllocInfo ai info Nothing -> ai }) filterOneAPI ovs (n, APIUnion u, maybeIgnores) = (n, APIUnion u {unionMethods = maybe (unionMethods u) (filterMethods (unionMethods u)) maybeIgnores , unionAllocationInfo = let ai = unionAllocationInfo u in case M.lookup n (allocInfo ovs) of Just info -> filterAllocInfo ai info Nothing -> ai }) -- The rest only apply if there are ignores. filterOneAPI _ (n, api, Nothing) = (n, api) filterOneAPI _ (n, APIObject o, Just ignores) = (n, APIObject o {objMethods = filterMethods (objMethods o) ignores, objSignals = filter ((`S.notMember` ignores) . sigName) (objSignals o) }) filterOneAPI ovs (n, APIInterface i, Just ignores) = (n, APIInterface i {ifMethods = filterMethods (ifMethods i) ignores, ifSignals = filter ((`S.notMember` ignores) . sigName) (ifSignals i), ifAllocationInfo = let ai = ifAllocationInfo i in case M.lookup n (allocInfo ovs) of Just info -> filterAllocInfo ai info Nothing -> ai }) 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)) haskell-gi-0.26.12/lib/Data/GI/CodeGen/PkgConfig.hs0000644000000000000000000000400707346545000017521 0ustar0000000000000000module Data.GI.CodeGen.PkgConfig ( pkgConfigGetVersion , tryPkgConfig ) where import Control.Monad (when) #if !MIN_VERSION_base(4,11,0) import Data.Monoid (First(..), (<>)) #else import Data.Monoid (First(..)) #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, and -- return the package name together with its version. 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 haskell-gi-0.26.12/lib/Data/GI/CodeGen/ProjectInfo.hs0000644000000000000000000007163407346545000020106 0ustar0000000000000000-- | Project information to include in generated bindings, should be -- kept in sync with haskell-gi.cabal module Data.GI.CodeGen.ProjectInfo ( homepage , authors , license , licenseText , category , maintainers , defaultExtensions , otherExtensions , ghcOptions , defaultLanguage , standardDeps ) where #if !MIN_VERSION_base(4,11,0) import Data.Monoid ((<>)) #endif import Data.Text (Text) import qualified Data.Text as T (unlines) homepage :: Text homepage = "https://github.com/haskell-gi/haskell-gi" authors :: Text authors = "Will Thompson and Iñaki García Etxebarria" maintainers :: Text maintainers = "Iñaki García Etxebarria" license :: Text license = "LGPL-2.1" -- | Default list of extensions to turn on when compiling the -- generated code. defaultExtensions :: [Text] defaultExtensions = ["NoImplicitPrelude", "ScopedTypeVariables", "CPP", "OverloadedStrings", "NegativeLiterals", "ConstraintKinds", "TypeFamilies", "MultiParamTypeClasses", "KindSignatures", "FlexibleInstances", "UndecidableInstances", "DataKinds", "FlexibleContexts", "UndecidableSuperClasses", "TypeOperators"] -- | Extensions that will be used in some modules, but we do not wish -- to turn on by default. otherExtensions :: [Text] otherExtensions = ["PatternSynonyms", "ViewPatterns", "TypeApplications"] -- | Default options for GHC when compiling generated code. ghcOptions :: [Text] ghcOptions = ["-fno-warn-unused-imports", "-fno-warn-warnings-deprecations"] -- | Default version of the report to use. defaultLanguage :: Text defaultLanguage = "Haskell2010" -- | List of dependencies for all bindings. Notice that base is not -- included here, since not all bindings use the same base -- version. haskell-gi and haskell-gi-base are not included either, -- since the versions to use may change depending on whether we are -- using old style or new style bindings. standardDeps :: [Text] standardDeps = ["bytestring >= 0.10 && < 1", "containers >= 0.5 && < 1", "text >= 1.0 && < 3", "transformers >= 0.4 && < 1"] -- | Under which category in hackage should the generated bindings be listed. category :: Text category = "Bindings" staticLinkingException :: Text -> Text staticLinkingException name = T.unlines ["The " <> name <> " library and included works are provided under the terms of the" ,"GNU Library General Public License (LGPL) version 2.1 with the following" ,"exception:" ,"" ,"Static linking of applications or any other source to the " <> name <> " library" ,"does not constitute a modified or derivative work and does not require" ,"the author(s) to provide source code for said work, to link against the" ,"shared " <> name <> " libraries, or to link their applications against a" ,"user-supplied version of " <> name <> ". If you link applications to a modified" ,"version of " <> name <> ", then the changes to " <> name <> " must be provided under the" ,"terms of the LGPL." ,"" ,"----------------------------------------------------------------------------" ,""] licenseText :: Text -> Text licenseText name = staticLinkingException name <> T.unlines [" 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." ,"\f" ," 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." ,"\f" ," 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." ,"\f" ," 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." ,"\f" ," 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." ,"\f" ," 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." ,"\f" ," 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." ,"\f" ," 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." ,"\f" ," 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."] haskell-gi-0.26.12/lib/Data/GI/CodeGen/Properties.hs0000644000000000000000000006011007346545000020003 0ustar0000000000000000module Data.GI.CodeGen.Properties ( genInterfaceProperties , genObjectProperties , genNamespacedPropLabels ) where #if !MIN_VERSION_base(4,8,0) import Control.Applicative ((<$>)) #endif import Control.Monad (forM_, when, unless) #if !MIN_VERSION_base(4,11,0) import Data.Monoid ((<>)) #endif import Data.Text (Text) import qualified Data.Text as T import qualified Data.Set as S import Foreign.C.Types (CInt, CUInt) import Foreign.Storable (sizeOf) import Data.GI.CodeGen.API import Data.GI.CodeGen.Conversions import Data.GI.CodeGen.Code import Data.GI.CodeGen.GObject import Data.GI.CodeGen.Haddock (addSectionDocumentation, writeHaddock, RelativeDocPosition(DocBeforeSymbol)) import Data.GI.CodeGen.Inheritance (fullObjectPropertyList, fullInterfacePropertyList) import Data.GI.CodeGen.ModulePath (dotModulePath) import Data.GI.CodeGen.SymbolNaming (lowerName, upperName, classConstraint, hyphensToCamelCase, qualifiedSymbol, typeConstraint, callbackDynamicWrapper, callbackHaskellToForeign, callbackWrapperAllocator, safeCast, hackageModuleLink, moduleLocation, haddockAttrAnchor) import Data.GI.CodeGen.Type import Data.GI.CodeGen.Util propTypeStr :: Type -> ExcCodeGen Text propTypeStr t = case t of TBasicType TUTF8 -> return "String" TBasicType TFileName -> return "String" TBasicType TPtr -> return "Ptr" TByteArray -> return "ByteArray" TGHash _ _ -> return "Hash" TVariant -> return "Variant" TParamSpec -> return "ParamSpec" TGClosure _ -> return "Closure" TError -> return "GError" TGValue -> return "GValue" TBasicType TInt -> case sizeOf (0 :: CInt) of 4 -> return "Int32" n -> error ("Unsupported `gint' type length: " ++ show n) TBasicType TUInt -> case sizeOf (0 :: CUInt) of 4 -> return "UInt32" n -> error ("Unsupported `guint' type length: " ++ show n) TBasicType TLong -> return "Long" TBasicType TULong -> return "ULong" TBasicType TInt32 -> return "Int32" TBasicType TUInt32 -> return "UInt32" 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 TPtr) -> return "PtrGList" t@(TInterface n) -> do api <- findAPIByName n case api of APIEnum _ -> return "Enum" APIFlags _ -> return "Flags" APICallback _ -> return "Callback" APIStruct s -> if structIsBoxed s then return "Boxed" else notImplementedError $ "Unboxed struct property : " <> tshow t APIUnion u -> if unionIsBoxed u then return "Boxed" else notImplementedError $ "Unboxed union property : " <> tshow t APIObject o -> do isGO <- isGObject t if isGO then return "Object" else case (objGetValueFunc o, objSetValueFunc o) of (Just _, Just _) -> return "IsGValueInstance" _ -> notImplementedError $ "Non-GObject object property without known gvalue_set and/or gvalue_get: " <> tshow t APIInterface _ -> do isGO <- isGObject t if isGO then return "Object" else notImplementedError $ "Non-GObject interface property : " <> tshow t _ -> notImplementedError $ "Unknown interface property of type : " <> tshow t _ -> notImplementedError $ "Don't know how to handle properties of type " <> tshow t -- | Some types need casting to a concrete type before we can set or -- construct properties. For example, for non-GObject object -- properties we accept any instance of @IsX@ for convenience, but -- instance resolution of the IsGValueSetter requires a concrete -- type. The following code implements the cast on the given variable, -- if needed, and returns the name of the new variable of concrete -- type. castProp :: Type -> Text -> CodeGen e Text castProp t@(TInterface n) val = do api <- findAPIByName n case api of APIObject o -> do isGO <- isGObject t if not isGO then case (objGetValueFunc o, objSetValueFunc o) of (Just _, Just _) -> do let val' = prime val cast <- safeCast n line $ val' <> " <- " <> cast <> " " <> val return val' _ -> return val else return val _ -> return val castProp _ val = return val -- | The constraint for setting the given type in properties. propSetTypeConstraint :: Type -> CodeGen e Text propSetTypeConstraint (TGClosure Nothing) = return $ "(~) " <> parenthesize (typeShow ("GClosure" `con` [con0 "()"])) propSetTypeConstraint t = do isGO <- isGObject t if isGO then typeConstraint t else do isCallback <- typeIsCallback t hInType <- if isCallback then typeShow <$> foreignType t else typeShow <$> haskellType t return $ "(~) " <> if T.any (== ' ') hInType then parenthesize hInType else hInType -- | The constraint for transferring the given type into a property. propTransferTypeConstraint :: Type -> CodeGen e Text propTransferTypeConstraint t = do isGO <- isGObject t if isGO then typeConstraint t else do hInType <- typeShow <$> isoHaskellType t return $ "(~) " <> if T.any (== ' ') hInType then parenthesize hInType else hInType -- | The type of the return value of @attrTransfer@ for the given -- type. propTransferType :: Type -> CodeGen e Text propTransferType (TGClosure Nothing) = return $ typeShow ("GClosure" `con` [con0 "()"]) propTransferType t = do isCallback <- typeIsCallback t if isCallback then typeShow <$> foreignType t else typeShow <$> haskellType t -- | Given a value "v" of the given Haskell type, satisfying the -- constraint generated by 'propTransferTypeConstraint', convert it -- (allocating memory is necessary) to the type given by 'propTransferType'. genPropTransfer :: Text -> Type -> CodeGen e () genPropTransfer var (TGClosure Nothing) = line $ "return " <> var genPropTransfer var t = do isGO <- isGObject t if isGO then do ht <- typeShow <$> haskellType t line $ "unsafeCastTo " <> ht <> " " <> var else case t of TInterface tn@(Name _ n) -> do isCallback <- typeIsCallback t if not isCallback then line $ "return " <> var else do -- Callbacks need to be wrapped wrapper <- qualifiedSymbol (callbackHaskellToForeign n) tn maker <- qualifiedSymbol (callbackWrapperAllocator n) tn line $ maker <> " " <> parenthesize (wrapper <> " Nothing " <> var) _ -> line $ "return " <> var -- | Given a property, return the set of constraints on the types, and -- the type variables for the object and its value. attrType :: Property -> CodeGen e ([Text], Text) attrType prop = do resetTypeVariableScope isCallback <- typeIsCallback (propType prop) if isCallback then do ftype <- foreignType (propType prop) return ([], typeShow ftype) else do (t,constraints) <- argumentType (propType prop) WithoutClosures return (constraints, t) -- | Generate documentation for the given setter. setterDoc :: Name -> Property -> Text setterDoc n prop = T.unlines [ "Set the value of the “@" <> propName prop <> "@” property." , "When is enabled, this is equivalent to" , "" , "@" , "'Data.GI.Base.Attributes.set' " <> lowerName n <> " [ #" <> hPropName prop <> " 'Data.GI.Base.Attributes.:=' value ]" , "@"] genPropertySetter :: Text -> Name -> HaddockSection -> Property -> ExcCodeGen () genPropertySetter setter n docSection prop = group $ do (constraints, t) <- attrType prop isNullable <- typeIsNullable (propType prop) isCallback <- typeIsCallback (propType prop) cls <- classConstraint n let constraints' = "MonadIO m":(cls <> " o"):constraints tStr <- propTypeStr $ propType prop writeHaddock DocBeforeSymbol (setterDoc n prop) line $ setter <> " :: (" <> T.intercalate ", " constraints' <> ") => o -> " <> t <> " -> m ()" line $ setter <> " obj val = MIO.liftIO $ do" indent $ do val' <- castProp (propType prop) "val" line $ "B.Properties.setObjectProperty" <> tStr <> " obj \"" <> propName prop <> if isNullable && (not isCallback) then "\" (Just " <> val' <> ")" else "\" " <> val' export docSection setter -- | Generate documentation for the given getter. getterDoc :: Name -> Property -> Text getterDoc n prop = T.unlines [ "Get the value of the “@" <> propName prop <> "@” property." , "When is enabled, this is equivalent to" , "" , "@" , "'Data.GI.Base.Attributes.get' " <> lowerName n <> " #" <> hPropName prop , "@"] genPropertyGetter :: Text -> Name -> HaddockSection -> Property -> ExcCodeGen () genPropertyGetter getter n docSection prop = group $ do isNullable <- typeIsNullable (propType prop) let isMaybe = isNullable && propReadNullable prop /= Just False constructorType <- isoHaskellType (propType prop) tStr <- propTypeStr $ propType prop cls <- classConstraint n let constraints = "(MonadIO m, " <> cls <> " o)" outType = if isMaybe then maybeT constructorType else constructorType returnType = typeShow $ "m" `con` [outType] getProp = if isNullable && not isMaybe then "checkUnexpectedNothing \"" <> getter <> "\" $ B.Properties.getObjectProperty" <> tStr else "B.Properties.getObjectProperty" <> tStr -- Some property getters require in addition a constructor, which -- will convert the foreign value to the wrapped Haskell one. constructorArg <- if tStr `elem` ["Object", "Boxed"] then return $ " " <> typeShow constructorType else (if tStr == "Callback" then do callbackType <- haskellType (propType prop) return $ " " <> callbackDynamicWrapper (typeShow callbackType) else return "") writeHaddock DocBeforeSymbol (getterDoc n prop) line $ getter <> " :: " <> constraints <> " => o -> " <> returnType line $ getter <> " obj = MIO.liftIO $ " <> getProp <> " obj \"" <> propName prop <> "\"" <> constructorArg export docSection getter -- | Generate documentation for the given constructor. constructorDoc :: Property -> Text constructorDoc prop = T.unlines [ "Construct a `GValueConstruct` with valid value for the “@" <> propName prop <> "@” property. This is rarely needed directly, but it is used by `Data.GI.Base.Constructible.new`." ] genPropertyConstructor :: Text -> Name -> HaddockSection -> Property -> ExcCodeGen () genPropertyConstructor constructor n docSection prop = group $ do (constraints, t) <- attrType prop tStr <- propTypeStr $ propType prop isNullable <- typeIsNullable (propType prop) isCallback <- typeIsCallback (propType prop) cls <- classConstraint n let constraints' = (cls <> " o") : "MIO.MonadIO m" : constraints pconstraints = parenthesize (T.intercalate ", " constraints') <> " => " writeHaddock DocBeforeSymbol (constructorDoc prop) line $ constructor <> " :: " <> pconstraints <> t <> " -> m (GValueConstruct o)" line $ constructor <> " val = MIO.liftIO $ do" indent $ do val' <- castProp (propType prop) "val" line $ "MIO.liftIO $ B.Properties.constructObjectProperty" <> tStr <> " \"" <> propName prop <> if isNullable && (not isCallback) then "\" (P.Just " <> val' <> ")" else "\" " <> val' export docSection constructor -- | Generate documentation for the given setter. clearDoc :: Property -> Text clearDoc prop = T.unlines [ "Set the value of the “@" <> propName prop <> "@” property to `Nothing`." , "When is enabled, this is equivalent to" , "" , "@" , "'Data.GI.Base.Attributes.clear'" <> " #" <> hPropName prop , "@"] genPropertyClear :: Text -> Name -> HaddockSection -> Property -> ExcCodeGen () genPropertyClear clear n docSection prop = group $ do cls <- classConstraint n let constraints = ["MonadIO m", cls <> " o"] tStr <- propTypeStr $ propType prop writeHaddock DocBeforeSymbol (clearDoc prop) nothingType <- typeShow . maybeT <$> haskellType (propType prop) isCallback <- typeIsCallback (propType prop) let nothing = if isCallback then "FP.nullFunPtr" else "(Nothing :: " <> nothingType <> ")" line $ clear <> " :: (" <> T.intercalate ", " constraints <> ") => o -> m ()" line $ clear <> " obj = liftIO $ B.Properties.setObjectProperty" <> tStr <> " obj \"" <> propName prop <> "\" " <> nothing export docSection clear -- | The property name as a lexically valid Haskell identifier. Note -- that this is not escaped, since it is assumed that it will be used -- with a prefix, so if a property is named "class", for example, this -- will return "class". hPropName :: Property -> Text hPropName = lcFirst . hyphensToCamelCase . propName genObjectProperties :: Name -> Object -> CodeGen e () 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 $ "'(\"" <> hPropName prop <> "\", " <> pi <> ")") genProperties n (objProperties o) allProps genInterfaceProperties :: Name -> Interface -> CodeGen e () genInterfaceProperties n iface = do allProps <- fullInterfacePropertyList n iface >>= mapM (\(owner, prop) -> do pi <- infoType owner prop return $ "'(\"" <> hPropName 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 -> Text -> Name -> Text -> CodeGen e Text accessorOrUndefined available accessor owner@(Name _ on) cName = if not available then return "undefined" else qualifiedSymbol (accessor <> on <> cName) owner -- | The name of the type encoding the information for the property of -- the object. infoType :: Name -> Property -> CodeGen e Text infoType owner prop = let infoType = upperName owner <> (hyphensToCamelCase . propName) prop <> "PropertyInfo" in qualifiedSymbol infoType owner genOneProperty :: Name -> Property -> ExcCodeGen () genOneProperty owner prop = do let name = upperName owner cName = (hyphensToCamelCase . propName) prop lcAttr = lcFirst cName docSection = NamedSubsection PropertySection lcAttr pName = name <> cName flags = propFlags prop writable = PropertyWritable `elem` flags && (PropertyConstructOnly `notElem` flags) readable = PropertyReadable `elem` flags constructOnly = PropertyConstructOnly `elem` flags addSectionDocumentation docSection (propDoc prop) -- 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 " <> tshow (propTransfer prop) isNullable <- typeIsNullable (propType prop) unless (readable || writable || constructOnly) $ notImplementedError $ "Property is not readable, writable, or constructible: " <> tshow pName group $ do line $ "-- VVV Prop \"" <> propName prop <> "\"" line $ " -- Type: " <> tshow (propType prop) line $ " -- Flags: " <> tshow (propFlags prop) line $ " -- Nullable: " <> tshow (propReadNullable prop, propWriteNullable prop) getter <- accessorOrUndefined readable "get" owner cName setter <- accessorOrUndefined writable "set" owner cName constructor <- accessorOrUndefined (writable || constructOnly) "construct" owner cName clear <- accessorOrUndefined (isNullable && writable && propWriteNullable prop /= Just False) "clear" owner cName when (getter /= "undefined") $ genPropertyGetter getter owner docSection prop when (setter /= "undefined") $ genPropertySetter setter owner docSection prop when (constructor /= "undefined") $ genPropertyConstructor constructor owner docSection prop when (clear /= "undefined") $ genPropertyClear clear owner docSection prop outType <- if not readable then return "()" else do sOutType <- if isNullable && propReadNullable prop /= Just False then typeShow . maybeT <$> isoHaskellType (propType prop) else typeShow <$> isoHaskellType (propType prop) return $ if T.any (== ' ') sOutType then parenthesize sOutType else sOutType -- Polymorphic #label style lens cppIf CPPOverloading $ do cls <- classConstraint owner inConstraint <- if writable || constructOnly then propSetTypeConstraint (propType prop) else return "(~) ()" transferConstraint <- if writable || constructOnly then propTransferTypeConstraint (propType prop) else return "(~) ()" transferType <- if writable || constructOnly then propTransferType (propType prop) else return "()" let allowedOps = (if writable then ["'AttrSet", "'AttrConstruct"] else []) <> (if constructOnly then ["'AttrConstruct"] else []) <> (if readable then ["'AttrGet"] else []) <> (if isNullable && propWriteNullable prop /= Just False then ["'AttrClear"] else []) it <- infoType owner prop export docSection it api <- findAPIByName owner hackageLink <- hackageModuleLink owner let qualifiedAttrName = dotModulePath (moduleLocation owner api) <> "." <> lcAttr attrInfoURL = hackageLink <> "#" <> haddockAttrAnchor <> lcAttr bline $ "data " <> it line $ "instance AttrInfo " <> it <> " where" indent $ do line $ "type AttrAllowedOps " <> it <> " = '[ " <> T.intercalate ", " allowedOps <> "]" line $ "type AttrBaseTypeConstraint " <> it <> " = " <> cls line $ "type AttrSetTypeConstraint " <> it <> " = " <> inConstraint line $ "type AttrTransferTypeConstraint " <> it <> " = " <> transferConstraint line $ "type AttrTransferType " <> it <> " = " <> transferType line $ "type AttrGetType " <> it <> " = " <> outType line $ "type AttrLabel " <> it <> " = \"" <> propName prop <> "\"" line $ "type AttrOrigin " <> it <> " = " <> name line $ "attrGet = " <> getter line $ "attrSet = " <> setter if writable || constructOnly then do line $ "attrTransfer _ v = do" indent $ genPropTransfer "v" (propType prop) else line $ "attrTransfer _ = undefined" line $ "attrConstruct = " <> constructor line $ "attrClear = " <> clear line $ "dbgAttrInfo = P.Just (O.ResolvedSymbolInfo {" indent $ do line $ "O.resolvedSymbolName = \"" <> qualifiedAttrName <> "\"" line $ ", O.resolvedSymbolURL = \"" <> attrInfoURL <> "\"" line $ "})" -- | Generate a placeholder property for those cases in which code -- generation failed. genPlaceholderProperty :: Name -> Property -> CodeGen e () genPlaceholderProperty owner prop = do line $ "-- XXX Placeholder" it <- infoType owner prop let cName = (hyphensToCamelCase . propName) prop docSection = NamedSubsection PropertySection (lcFirst cName) export docSection it bline $ "data " <> it line $ "instance AttrInfo " <> it <> " where" indent $ do line $ "type AttrAllowedOps " <> it <> " = '[]" line $ "type AttrSetTypeConstraint " <> it <> " = (~) ()" line $ "type AttrTransferTypeConstraint " <> it <> " = (~) ()" line $ "type AttrTransferType " <> it <> " = ()" line $ "type AttrBaseTypeConstraint " <> it <> " = (~) ()" line $ "type AttrGetType " <> it <> " = ()" line $ "type AttrLabel " <> it <> " = \"\"" line $ "type AttrOrigin " <> it <> " = " <> upperName owner line $ "attrGet = undefined" line $ "attrSet = undefined" line $ "attrConstruct = undefined" line $ "attrClear = undefined" line $ "attrTransfer = undefined" genProperties :: Name -> [Property] -> [Text] -> CodeGen e () genProperties n ownedProps allProps = do let name = upperName n forM_ ownedProps $ \prop -> do handleCGExc (\err -> do line $ "-- XXX Generation of property \"" <> propName prop <> "\" of object \"" <> name <> "\" failed." printCGError err cppIf CPPOverloading (genPlaceholderProperty n prop)) (genOneProperty n prop) cppIf CPPOverloading $ do let propListType = name <> "AttributeList" line $ "instance O.HasAttributeList " <> name line $ "type instance O.AttributeList " <> name <> " = " <> propListType line $ "type " <> propListType <> " = ('[ " <> T.intercalate ", " allProps <> "] :: [(Symbol, DK.Type)])" -- | Generate gtk2hs compatible attribute labels (to ease -- porting). These are namespaced labels, for examples -- `widgetSensitive`. We take the list of methods, since there may be -- name clashes (an example is Auth::is_for_proxy method in libsoup, -- and the corresponding Auth::is-for-proxy property). When there is a -- clash we give priority to the method. genNamespacedPropLabels :: Name -> [Property] -> [Method] -> CodeGen e () genNamespacedPropLabels owner props methods = let lName = lcFirst . hyphensToCamelCase . propName in genNamespacedAttrLabels owner (map lName props) methods genNamespacedAttrLabels :: Name -> [Text] -> [Method] -> CodeGen e () genNamespacedAttrLabels owner attrNames methods = do let name = upperName owner let methodNames = S.fromList (map (lowerName . methodName) methods) filteredAttrs = filter (`S.notMember` methodNames) attrNames forM_ filteredAttrs $ \attr -> group $ do let cName = ucFirst attr labelProxy = lcFirst name <> cName docSection = NamedSubsection PropertySection (lcFirst cName) line $ labelProxy <> " :: AttrLabelProxy \"" <> lcFirst cName <> "\"" line $ labelProxy <> " = AttrLabelProxy" export docSection labelProxy haskell-gi-0.26.12/lib/Data/GI/CodeGen/Signal.hs0000644000000000000000000006006707346545000017077 0ustar0000000000000000module Data.GI.CodeGen.Signal ( genSignal , genCallback , signalHaskellName ) where import Control.Monad (forM, forM_, when, unless) import Data.Maybe (catMaybes, isJust) #if !MIN_VERSION_base(4,11,0) import Data.Monoid ((<>)) #endif import Data.Bool (bool) import qualified Data.Text as T import Data.Text (Text) import Text.Show.Pretty (ppShow) import Data.GI.CodeGen.API import Data.GI.CodeGen.Callable (hOutType, wrapMaybe, fixupCallerAllocates, genDynamicCallableWrapper, callableHInArgs, callableHOutArgs) import Data.GI.CodeGen.Code import Data.GI.CodeGen.Conversions import Data.GI.CodeGen.Haddock (deprecatedPragma, RelativeDocPosition(..), writeHaddock, writeDocumentation, writeArgDocumentation, writeReturnDocumentation) import Data.GI.CodeGen.ModulePath (dotModulePath) import Data.GI.CodeGen.SymbolNaming import Data.GI.CodeGen.Transfer (freeContainerType) import Data.GI.CodeGen.Type import Data.GI.CodeGen.Util (parenthesize, withComment, tshow, terror, lcFirst, ucFirst, prime) import Data.GI.GIR.Documentation (Documentation) -- | The prototype of the callback on the Haskell side (what users of -- the binding will see) genHaskellCallbackPrototype :: Text -> Callable -> Text -> ExposeClosures -> Bool -> Documentation -> ExcCodeGen () genHaskellCallbackPrototype subsec cb htype expose isSignal doc = group $ do let name' = case expose of WithClosures -> callbackHTypeWithClosures htype WithoutClosures -> htype (hInArgs, _) = callableHInArgs cb expose inArgsWithArrows = zip ("" : repeat "-> ") hInArgs hOutArgs = callableHOutArgs cb export (NamedSubsection SignalSection subsec) name' writeDocumentation DocBeforeSymbol doc line $ "type " <> name' <> " =" indent $ do forM_ inArgsWithArrows $ \(arrow, arg) -> do ht <- isoHaskellType (argType arg) isMaybe <- wrapMaybe arg let formattedType = if isMaybe then typeShow (maybeT ht) else typeShow ht line $ arrow <> formattedType writeArgDocumentation arg ret <- hOutType cb hOutArgs let returnArrow = if null hInArgs then "" else "-> " line $ returnArrow <> typeShow (io ret) writeReturnDocumentation cb False when (not isSignal) $ do blank -- For optional parameters, in case we want to pass Nothing. export (NamedSubsection SignalSection subsec) ("no" <> name') writeHaddock DocBeforeSymbol (noCallbackDoc name') line $ "no" <> name' <> " :: Maybe " <> name' line $ "no" <> name' <> " = Nothing" where noCallbackDoc :: Text -> Text noCallbackDoc typeName = "A convenience synonym for @`Nothing` :: `Maybe` `" <> typeName <> "`@." -- | Generate the type synonym for the prototype of the callback on -- the C side. Returns the name given to the type synonym. genCCallbackPrototype :: Text -> Callable -> Text -> Maybe Text -> CodeGen e Text genCCallbackPrototype subsec cb name' maybeOwner = group $ do let ctypeName = callbackCType name' isSignal = isJust maybeOwner when (not isSignal) $ do export (NamedSubsection SignalSection subsec) ctypeName writeHaddock DocBeforeSymbol ccallbackDoc line $ "type " <> ctypeName <> " =" indent $ do maybe (return ()) (\owner -> line $ withComment ("Ptr " <> owner <> " ->") "object") maybeOwner forM_ (args cb) $ \arg -> do ht <- foreignType $ argType arg let ht' = if direction arg /= DirectionIn && not (argCallerAllocates arg) then ptr ht else ht line $ typeShow ht' <> " ->" when (callableThrows cb) $ line "Ptr (Ptr GError) ->" when (isJust maybeOwner) $ line $ withComment "Ptr () ->" "user_data" ret <- io <$> case returnType cb of Nothing -> return $ con0 "()" Just t -> foreignType t line $ typeShow ret return ctypeName where ccallbackDoc :: Text ccallbackDoc = "Type for the callback on the (unwrapped) C side." -- | Generator for wrappers callable from C genCallbackWrapperFactory :: Text -> Text -> Bool -> CodeGen e () genCallbackWrapperFactory subsec name' isSignal = group $ do let factoryName = callbackWrapperAllocator name' writeHaddock DocBeforeSymbol factoryDoc line "foreign import ccall \"wrapper\"" indent $ line $ factoryName <> " :: " <> callbackCType name' <> " -> IO (FunPtr " <> callbackCType name' <> ")" when (not isSignal) $ do export (NamedSubsection SignalSection subsec) factoryName where factoryDoc :: Text factoryDoc = "Generate a function pointer callable from C code, from a `" <> callbackCType name' <> "`." -- | Wrap the Haskell `cb` callback into a foreign function of the -- right type. Returns the name of the wrapped value. genWrappedCallback :: Callable -> Text -> Text -> Bool -> CodeGen e Text genWrappedCallback cb cbArg callback isSignal = do drop <- if callableHasClosures cb then do let arg' = prime cbArg line $ "let " <> arg' <> " = " <> callbackDropClosures callback <> " " <> cbArg return arg' else return cbArg line $ "let " <> prime drop <> " = " <> callbackHaskellToForeign callback <> if isSignal then " " <> drop else " Nothing " <> drop return (prime drop) -- | Generator of closures genClosure :: Text -> Callable -> Text -> Text -> CodeGen e () genClosure subsec cb callback name = group $ do let closure = callbackClosureGenerator name export (NamedSubsection SignalSection subsec) closure writeHaddock DocBeforeSymbol closureDoc group $ do line $ closure <> " :: MonadIO m => " <> callback <> " -> m (GClosure " <> callbackCType callback <> ")" line $ closure <> " cb = liftIO $ do" indent $ do wrapped <- genWrappedCallback cb "cb" callback False line $ callbackWrapperAllocator callback <> " " <> wrapped <> " >>= B.GClosure.newGClosure" where closureDoc :: Text closureDoc = "Wrap the callback into a `GClosure`." -- | Wrap a conversion of a nullable object into "Maybe" object, by -- checking whether the pointer is NULL. convertNullable :: Text -> CodeGen e Text -> Type -> CodeGen e Text convertNullable aname c t = do nullPtr <- nullPtrForType t >>= \case Nothing -> terror $ "Unexpected non-pointer type " <> tshow t Just null -> pure null 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 -> Text -> ExcCodeGen Text convertCallbackInCArray callable arg t@(TCArray False (-1) length _) aname = if length > -1 then wrapMaybe arg >>= bool convertAndFree (convertNullable aname convertAndFree t) else -- Not much we can do, we just pass the pointer along, and let -- the callback deal with it. return aname where lname = escapedArgName $ args callable !! length convertAndFree :: ExcCodeGen Text 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 _ _ = terror $ "convertOutCArray : unexpected " <> tshow t -- Prepare an argument for passing into the Haskell side. prepareArgForCall :: Callable -> Arg -> ExcCodeGen Text prepareArgForCall cb arg = case direction arg of DirectionIn -> prepareInArg cb arg DirectionInout -> prepareInoutArg arg DirectionOut -> terror "Unexpected DirectionOut!" prepareInArg :: Callable -> Arg -> ExcCodeGen Text prepareInArg cb arg = do let name = escapedArgName arg case argType arg of t@(TCArray False _ _ _) -> convertCallbackInCArray cb arg t name _ -> do let c = convert name $ transientToH (argType arg) (transfer arg) wrapMaybe arg >>= bool c (convertNullable name c (argType arg)) prepareInoutArg :: Arg -> ExcCodeGen Text prepareInoutArg arg = do let name = escapedArgName arg name' <- genConversion name $ apply $ M "peek" convert name' $ fToH (argType arg) (transfer arg) saveOutArg :: Arg -> ExcCodeGen () saveOutArg arg = do let name = escapedArgName arg name' = "out" <> name when (transfer arg /= TransferEverything) $ notImplementedError $ "Unexpected transfer type for \"" <> name <> "\"" isMaybe <- wrapMaybe arg name'' <- if isMaybe then do let name'' = prime name' line $ name'' <> " <- case " <> name' <> " of" indent $ do line "Nothing -> return nullPtr" line $ "Just " <> name'' <> " -> do" indent $ do converted <- convert name'' $ hToF (argType arg) TransferEverything line $ "return " <> converted return name'' else convert name' $ hToF (argType arg) TransferEverything line $ "poke " <> name <> " " <> name'' -- | A simple wrapper that drops every closure argument. genDropClosures :: Text -> Callable -> Text -> CodeGen e () genDropClosures subsec cb name' = group $ do let dropper = callbackDropClosures name' (inWithClosures, _) = callableHInArgs cb WithClosures (inWithoutClosures, _) = callableHInArgs cb WithoutClosures passOrIgnore = \arg -> if arg `elem` inWithoutClosures then Just (escapedArgName arg) else Nothing argNames = map (maybe "_" id . passOrIgnore) inWithClosures export (NamedSubsection SignalSection subsec) dropper writeHaddock DocBeforeSymbol dropperDoc line $ dropper <> " :: " <> name' <> " -> " <> callbackHTypeWithClosures name' line $ dropper <> " _f " <> T.unwords argNames <> " = _f " <> T.unwords (catMaybes (map passOrIgnore inWithClosures)) where dropperDoc :: Text dropperDoc = "A simple wrapper that ignores the closure arguments." -- | The wrapper itself, marshalling to and from Haskell. The `Callable` -- 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 :: Text -> Callable -> Text -> Maybe Text -> CodeGen e () genCallbackWrapper subsec cb name' maybeOwner = group $ do let wrapperName = callbackHaskellToForeign name' (hInArgs, _) = callableHInArgs cb WithClosures hOutArgs = callableHOutArgs cb wrapperDoc = "Wrap a `" <> name' <> "` into a `" <> callbackCType name' <> "`." isSignal = isJust maybeOwner when (not isSignal) $ do export (NamedSubsection SignalSection subsec) wrapperName writeHaddock DocBeforeSymbol wrapperDoc group $ do line $ wrapperName <> " :: " indent $ do if isSignal then line $ "GObject a => (a -> " <> name' <> ") ->" else do line $ "Maybe (Ptr (FunPtr " <> callbackCType name' <> ")) ->" let hType = if callableHasClosures cb then callbackHTypeWithClosures name' else name' line $ hType <> " ->" line $ callbackCType name' let cArgNames = map escapedArgName (args cb) allArgs = if isSignal then T.unwords $ ["gi'cb", "gi'selfPtr"] <> cArgNames <> ["_"] else T.unwords $ ["gi'funptrptr", "gi'cb"] <> cArgNames line $ wrapperName <> " " <> allArgs <> " = do" handleCGExc (\e -> indent $ do line $ "-- XXX Could not generate callback wrapper for " <> name' printCGError e line $ "P.error \"The bindings for " <> wrapperName <> " could not be generated, function unsupported.\"" ) $ indent $ do hInNames <- forM hInArgs (prepareArgForCall cb) let maybeReturn = case returnType cb of Nothing -> [] _ -> ["result"] returnVars = maybeReturn <> map (("out"<>) . escapedArgName) hOutArgs mkTuple = parenthesize . T.intercalate ", " returnBind = case returnVars of [] -> "" [r] -> r <> " <- " _ -> mkTuple returnVars <> " <- " if isSignal then line $ returnBind <> "B.ManagedPtr.withNewObject" <> " gi'selfPtr $ \\gi'self -> " <> "gi'cb (Coerce.coerce gi'self) " <> T.concat (map (" " <>) hInNames) else line $ returnBind <> "gi'cb " <> T.concat (map (" " <>) hInNames) forM_ hOutArgs saveOutArg unless isSignal $ line "maybeReleaseFunPtr gi'funptrptr" case returnType cb of Nothing -> return () Just r -> do nullableReturnType <- typeIsNullable r if returnMayBeNull cb && nullableReturnType then do line "maybeM FP.nullPtr result $ \\result' -> do" indent $ unwrapped "result'" else unwrapped "result" where unwrapped rname = do result' <- convert rname $ hToF r (returnTransfer cb) line $ "return " <> result' genCallback :: Name -> Callback -> CodeGen e () genCallback n callback@(Callback {cbCallable = cb, cbDocumentation = cbDoc }) = do let Name _ name' = normalizedAPIName (APICallback callback) n cb' = fixupCallerAllocates cb line $ "-- callback " <> name' line $ "{- " <> T.pack (ppShow cb') <> "\n-}" if skipReturn cb then group $ do line $ "-- XXX Skipping callback " <> name' line $ "{- Callbacks skipping return unsupported :\n" <> T.pack (ppShow n) <> "\n" <> T.pack (ppShow cb') <> "-}" else do handleCGExc (\e -> do line $ "-- XXX Could not generate callback wrapper for " <> name' printCGError e) $ do typeSynonym <- genCCallbackPrototype name' cb' name' Nothing dynamic <- genDynamicCallableWrapper n typeSynonym cb export (NamedSubsection SignalSection name') dynamic genCallbackWrapperFactory name' name' False deprecatedPragma name' (callableDeprecated cb') genHaskellCallbackPrototype name' cb' name' WithoutClosures False cbDoc when (callableHasClosures cb') $ do genHaskellCallbackPrototype name' cb' name' WithClosures False cbDoc genDropClosures name' cb' name' if callableThrows cb' then do {- [Note: Callables that throw] In the case that the Callable throws (GErrors) we cannot simply take a Haskell functions that throws and wrap it into a foreign function, since in the case that an exception is raised the return value of the function is undefined, but we need to provide some value to the FFI. Alternatively, we could ask the Haskell function to provide a return value and optionally a GError. If the GError is present we should then release the memory associated with the out/return values (the caller will not do it, since there was an error), and then return some bogus values. This is fairly complicated, and callbacks raising GErrors are fairly rare, so for the moment we do not generate wrappers for these cases. -} line $ "-- No Haskell->C wrapper generated since the function throws." blank else do genClosure name' cb' name' name' genCallbackWrapper name' cb' name' Nothing -- | Generate the given signal instance for the given API object. genSignalInfoInstance :: Name -> Signal -> CodeGen e () genSignalInfoInstance owner signal = group $ do api <- findAPIByName owner let name = upperName owner sn = (ucFirst . signalHaskellName . sigName) signal lcSignal = lcFirst sn qualifiedSignalName = dotModulePath (moduleLocation owner api) <> "::" <> sigName signal hackageLink <- hackageModuleLink owner si <- signalInfoName owner signal bline $ "data " <> si line $ "instance SignalInfo " <> si <> " where" indent $ do let signalConnectorName = name <> sn cbHaskellType = signalConnectorName <> "Callback" line $ "type HaskellCallbackType " <> si <> " = " <> cbHaskellType line $ "connectSignal obj cb connectMode detail = do" indent $ do genSignalConnector signal cbHaskellType "connectMode" "detail" "cb" line $ "dbgSignalInfo = P.Just (O.ResolvedSymbolInfo {" indent $ do line $ "O.resolvedSymbolName = \"" <> qualifiedSignalName <> "\"" line $ ", O.resolvedSymbolURL = \"" <> hackageLink <> "#" <> haddockSignalAnchor <> lcSignal <> "\"})" export (NamedSubsection SignalSection $ lcSignal) si -- | Write some simple debug message when signal generation fails, and -- generate a placeholder SignalInfo instance. processSignalError :: Signal -> Name -> CGError -> CodeGen e () processSignalError signal owner err = do let qualifiedSignalName = upperName owner <> "::" <> sigName signal sn = (ucFirst . signalHaskellName . sigName) signal line $ T.concat ["-- XXX Could not generate signal " , qualifiedSignalName , "\n", "-- Error was : "] printCGError err -- Generate a placeholder SignalInfo instance that raises a type -- error when one attempts to use it. cppIf CPPOverloading $ group $ do si <- signalInfoName owner signal bline $ "data " <> si line $ "instance SignalInfo " <> si <> " where" indent $ do line $ "type HaskellCallbackType " <> si <> " = B.Signals.SignalCodeGenError \"" <> qualifiedSignalName <> "\"" line $ "connectSignal = undefined" export (NamedSubsection SignalSection $ lcFirst sn) si -- | Generate a wrapper for a signal. genSignal :: Signal -> Name -> CodeGen e () genSignal s@(Signal { sigName = sn, sigCallable = cb }) on = handleCGExc (processSignalError s on) $ do let on' = upperName on line $ "-- signal " <> on' <> "::" <> sn let sn' = signalHaskellName sn signalConnectorName = on' <> ucFirst sn' cbType = signalConnectorName <> "Callback" docSection = NamedSubsection SignalSection $ lcFirst sn' deprecatedPragma cbType (callableDeprecated cb) genHaskellCallbackPrototype (lcFirst sn') cb cbType WithoutClosures True (sigDoc s) _ <- genCCallbackPrototype (lcFirst sn') cb cbType (Just on') genCallbackWrapperFactory (lcFirst sn') cbType True if callableThrows cb then do line $ "-- No Haskell->C wrapper generated since the function throws." blank else do genCallbackWrapper (lcFirst sn') cb cbType (Just on') -- 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 -- Notice that we do not include GObject here as a constraint, -- since if something provides signals it is necessarily a -- GObject. klass <- classConstraint on addLanguagePragma "ImplicitParams" addLanguagePragma "RankNTypes" let signatureConstraints = "(" <> klass <> " a, MonadIO m) =>" implicitSelfCBType = "((?self :: a) => " <> cbType <> ")" signatureArgs = if sigDetailed s then "a -> P.Maybe T.Text -> " <> implicitSelfCBType <> " -> m SignalHandlerId" else "a -> " <> implicitSelfCBType <> " -> m SignalHandlerId" signature = " :: " <> signatureConstraints <> " " <> signatureArgs onName = "on" <> signalConnectorName afterName = "after" <> signalConnectorName group $ do writeHaddock DocBeforeSymbol onDoc line $ onName <> signature if sigDetailed s then do line $ onName <> " obj detail cb = liftIO $ do" indent $ do line $ "let wrapped self = let ?self = self in cb" genSignalConnector s cbType "SignalConnectBefore" "detail" "wrapped" else do line $ onName <> " obj cb = liftIO $ do" indent $ do line $ "let wrapped self = let ?self = self in cb" genSignalConnector s cbType "SignalConnectBefore" "Nothing" "wrapped" export docSection onName group $ do writeHaddock DocBeforeSymbol afterDoc line $ afterName <> signature if sigDetailed s then do line $ afterName <> " obj detail cb = liftIO $ do" indent $ do line $ "let wrapped self = let ?self = self in cb" genSignalConnector s cbType "SignalConnectAfter" "detail" "wrapped" else do line $ afterName <> " obj cb = liftIO $ do" indent $ do line $ "let wrapped self = let ?self = self in cb" genSignalConnector s cbType "SignalConnectAfter" "Nothing" "wrapped" export docSection afterName cppIf CPPOverloading (genSignalInfoInstance on s) where onDoc :: Text onDoc = let hsn = signalHaskellName sn in T.unlines [ "Connect a signal handler for the [" <> hsn <> "](#signal:" <> hsn <> ") signal, to be run before the default handler." , "When is enabled, this is equivalent to" , "" , "@" , "'Data.GI.Base.Signals.on' " <> lowerName on <> " #" <> hsn <> " callback" , "@" , "" , detailedDoc ] afterDoc :: Text afterDoc = let hsn = signalHaskellName sn in T.unlines [ "Connect a signal handler for the [" <> hsn <> "](#signal:" <> hsn <> ") signal, to be run after the default handler." , "When is enabled, this is equivalent to" , "" , "@" , "'Data.GI.Base.Signals.after' " <> lowerName on <> " #" <> hsn <> " callback" , "@" , "" , detailedDoc , "" , selfDoc] detailedDoc :: Text detailedDoc = if not (sigDetailed s) then "" else T.unlines [ "This signal admits a optional parameter @detail@." , "If it's not @Nothing@, we will connect to “@" <> sn <> "::detail@” instead." ] selfDoc :: Text selfDoc = T.unlines [ "By default the object invoking the signal is not passed to the callback." , "If you need to access it, you can use the implit @?self@ parameter." , "Note that this requires activating the @ImplicitParams@ GHC extension." ] -- | Generate the code for connecting the given signal. This assumes -- that it lives inside a @do@ block. genSignalConnector :: Signal -> Text -- ^ Callback type -> Text -- ^ SignalConnectBefore or SignalConnectAfter -> Text -- ^ Detail -> Text -- ^ Name of variable holding the callback -> CodeGen e () genSignalConnector (Signal {sigName = sn, sigCallable = cb}) cbType when detail cbName = do cb' <- genWrappedCallback cb cbName cbType True let cb'' = prime cb' line $ cb'' <> " <- " <> callbackWrapperAllocator cbType <> " " <> cb' line $ "connectSignalFunPtr obj \"" <> sn <> "\" " <> cb'' <> " " <> when <> " " <> detail haskell-gi-0.26.12/lib/Data/GI/CodeGen/Struct.hs0000644000000000000000000005703407346545000017146 0ustar0000000000000000-- | Marshalling of structs and unions. module Data.GI.CodeGen.Struct ( genStructOrUnionFields , genZeroStruct , genZeroUnion , extractCallbacksInStruct , fixAPIStructs , ignoreStruct , genBoxed , genWrappedPtr ) where #if !MIN_VERSION_base(4,8,0) import Control.Applicative ((<$>)) #endif import Control.Monad (forM, when) import Data.Maybe (mapMaybe, isJust, catMaybes) #if !MIN_VERSION_base(4,11,0) import Data.Monoid ((<>)) #endif import Data.Text (Text) import qualified Data.Text as T import Data.GI.CodeGen.API import Data.GI.CodeGen.Conversions import Data.GI.CodeGen.Code import Data.GI.CodeGen.Haddock (addSectionDocumentation, writeHaddock, RelativeDocPosition(DocBeforeSymbol)) import Data.GI.CodeGen.ModulePath (dotModulePath) import Data.GI.CodeGen.SymbolNaming (upperName, lowerName, underscoresToCamelCase, qualifiedSymbol, callbackHaskellToForeign, callbackWrapperAllocator, haddockAttrAnchor, moduleLocation, hackageModuleLink, normalizedAPIName) import Data.GI.CodeGen.Type import Data.GI.CodeGen.Util -- | Whether (not) to generate bindings for the given struct. ignoreStruct :: Name -> Struct -> Bool ignoreStruct (Name _ name) s = (isJust (gtypeStructFor s) || "Private" `T.isSuffixOf` name) && (not $ structForceVisible s) -- | Whether the given type corresponds to an ignored struct. isIgnoredStructType :: Type -> CodeGen e Bool isIgnoredStructType t = case t of TInterface n -> do api <- getAPI t case api of APIStruct s -> return (ignoreStruct n s) _ -> return False _ -> return False -- | Canonical name for the type of a callback type embedded in a -- struct field. fieldCallbackType :: Text -> Field -> Text fieldCallbackType structName field = structName <> (underscoresToCamelCase . 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 (Name 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 _ = [] -- | The name of the type encoding the information for a field in a -- struct/union. infoType :: Name -> Field -> CodeGen e Text infoType owner field = do let name = upperName owner let fName = (underscoresToCamelCase . fieldName) field return $ name <> fName <> "FieldInfo" -- | Whether a given field is an embedded struct/union. isEmbedded :: Field -> ExcCodeGen Bool isEmbedded field = do api <- findAPI (fieldType field) case api of Just (APIStruct _) -> checkEmbedding Just (APIUnion _) -> checkEmbedding _ -> return False where checkEmbedding :: ExcCodeGen Bool checkEmbedding = case fieldIsPointer field of Nothing -> badIntroError "Cannot determine whether the field is embedded." Just isPtr -> return (not isPtr) -- | Name for the getter function fieldGetter :: Name -> Field -> Text fieldGetter name' field = "get" <> upperName name' <> fName field -- | Generate documentation for the given getter. getterDoc :: Name -> Field -> Text getterDoc n field = T.unlines [ "Get the value of the “@" <> fieldName field <> "@” field." , "When is enabled, this is equivalent to" , "" , "@" , "'Data.GI.Base.Attributes.get' " <> lowerName n <> " #" <> labelName field , "@"] -- Notice that when reading the field we return a copy of any embedded -- structs, so modifications of the returned struct will not affect -- the original struct. This is on purpose, in order to increase -- safety (otherwise the garbage collector may decide to free the -- parent structure while we are modifying the embedded one, and havoc -- will ensue). -- | Extract a field from a struct. buildFieldReader :: Name -> Field -> ExcCodeGen () buildFieldReader n field = group $ do let name' = upperName n getter = fieldGetter n field embedded <- isEmbedded field nullConvert <- if embedded then return Nothing else maybeNullConvert (fieldType field) hType <- typeShow <$> if isJust nullConvert then maybeT <$> isoHaskellType (fieldType field) else isoHaskellType (fieldType field) fType <- typeShow <$> foreignType (fieldType field) writeHaddock DocBeforeSymbol (getterDoc n field) line $ getter <> " :: MonadIO m => " <> name' <> " -> m " <> if T.any (== ' ') hType then parenthesize hType else hType line $ getter <> " s = liftIO $ withManagedPtr s $ \\ptr -> do" indent $ do let peekedType = if T.any (== ' ') fType then parenthesize fType else fType if embedded then line $ "let val = ptr `plusPtr` " <> tshow (fieldOffset field) <> " :: " <> peekedType else line $ "val <- peek (ptr `plusPtr` " <> tshow (fieldOffset field) <> ") :: IO " <> peekedType result <- case nullConvert of Nothing -> convert "val" $ fToH (fieldType field) TransferNothing Just nullConverter -> do line $ "result <- " <> nullConverter <> " val $ \\val' -> do" indent $ do val' <- convert "val'" $ fToH (fieldType field) TransferNothing line $ "return " <> val' return "result" line $ "return " <> result -- | Name for the setter function fieldSetter :: Name -> Field -> Text fieldSetter name' field = "set" <> upperName name' <> fName field -- | Generate documentation for the given setter. setterDoc :: Name -> Field -> Text setterDoc n field = T.unlines [ "Set the value of the “@" <> fieldName field <> "@” field." , "When is enabled, this is equivalent to" , "" , "@" , "'Data.GI.Base.Attributes.set' " <> lowerName n <> " [ #" <> labelName field <> " 'Data.GI.Base.Attributes.:=' value ]" , "@"] -- | Write a field into a struct. Note that, since we cannot know for -- sure who will be deallocating the fields in the struct, we leave -- any conversions that involve pointers to the caller. What this -- means in practice is that scalar fields will get marshalled to/from -- Haskell, while anything that involves pointers will be returned in -- the C representation. buildFieldWriter :: Name -> Field -> ExcCodeGen () buildFieldWriter n field = group $ do let name' = upperName n let setter = fieldSetter n field isPtr <- typeIsPtr (fieldType field) fType <- typeShow <$> foreignType (fieldType field) hType <- if isPtr then return fType else typeShow <$> haskellType (fieldType field) writeHaddock DocBeforeSymbol (setterDoc n field) line $ setter <> " :: MonadIO m => " <> name' <> " -> " <> hType <> " -> m ()" line $ setter <> " s val = liftIO $ withManagedPtr s $ \\ptr -> do" indent $ do converted <- if isPtr then return "val" else convert "val" $ hToF (fieldType field) TransferNothing line $ "poke (ptr `plusPtr` " <> tshow (fieldOffset field) <> ") (" <> converted <> " :: " <> fType <> ")" -- | Name for the clear function fieldClear :: Name -> Field -> Text fieldClear name' field = "clear" <> upperName name' <> fName field -- | Documentation for the @clear@ method. clearDoc :: Field -> Text clearDoc field = T.unlines [ "Set the value of the “@" <> fieldName field <> "@” field to `Nothing`." , "When is enabled, this is equivalent to" , "" , "@" , "'Data.GI.Base.Attributes.clear'" <> " #" <> labelName field , "@"] -- | Write a @NULL@ into a field of a struct of type `Ptr`. buildFieldClear :: Name -> Field -> Text -> ExcCodeGen () buildFieldClear n field nullPtr = group $ do let name' = upperName n let clear = fieldClear n field fType <- typeShow <$> foreignType (fieldType field) writeHaddock DocBeforeSymbol (clearDoc field) line $ clear <> " :: MonadIO m => " <> name' <> " -> m ()" line $ clear <> " s = liftIO $ withManagedPtr s $ \\ptr -> do" indent $ line $ "poke (ptr `plusPtr` " <> tshow (fieldOffset field) <> ") (" <> nullPtr <> " :: " <> fType <> ")" -- | Return whether the given type corresponds to a callback that does -- not throw exceptions. If it is, return the callback itself. See -- [Note: Callables that throw] for the reason why we do not try to -- wrap callbacks that throw exceptions. isRegularCallback :: Type -> CodeGen e (Maybe Callback) isRegularCallback t@(TInterface _) = do api <- getAPI t case api of APICallback callback@(Callback {cbCallable = callable}) -> if callableThrows callable then return Nothing else return (Just callback) _ -> return Nothing isRegularCallback _ = return Nothing -- | The types accepted by the allocating set function -- 'Data.GI.Base.Attributes.(:&=)'. fieldTransferTypeConstraint :: Type -> CodeGen e Text fieldTransferTypeConstraint t = do isPtr <- typeIsPtr t maybeRegularCallback <- isRegularCallback t inType <- if isPtr && not (isJust maybeRegularCallback) then typeShow <$> foreignType t else typeShow <$> isoHaskellType t return $ "(~)" <> if T.any (== ' ') inType then parenthesize inType else inType -- | The type generated by 'Data.GI.Base.attrTransfer' for this -- field. This type should satisfy the -- 'Data.GI.Base.Attributes.AttrSetTypeConstraint' for the type. fieldTransferType :: Type -> CodeGen e Text fieldTransferType t = do isPtr <- typeIsPtr t inType <- if isPtr then typeShow <$> foreignType t else typeShow <$> haskellType t return $ if T.any (== ' ') inType then parenthesize inType else inType -- | Generate the field transfer function, which marshals Haskell -- values to types that we can set, even if we need to allocate memory. genFieldTransfer :: Text -> Type -> CodeGen e () genFieldTransfer var t@(TInterface tn) = do maybeRegularCallback <- isRegularCallback t case maybeRegularCallback of Just callback -> do let Name _ name' = normalizedAPIName (APICallback callback) tn wrapper <- qualifiedSymbol (callbackHaskellToForeign name') tn maker <- qualifiedSymbol (callbackWrapperAllocator name') tn line $ maker <> " " <> parenthesize (wrapper <> " Nothing " <> var) Nothing -> line $ "return " <> var genFieldTransfer var _ = line $ "return " <> var -- | Haskell name for the field fName :: Field -> Text fName = underscoresToCamelCase . fieldName -- | Label associated to the field. labelName :: Field -> Text labelName = lcFirst . fName -- | Support for modifying fields as attributes. Returns a tuple with -- the name of the overloaded label to be used for the field, and the -- associated info type. genAttrInfo :: Name -> Field -> ExcCodeGen Text genAttrInfo owner field = do it <- infoType owner field let on = upperName owner isPtr <- typeIsPtr (fieldType field) embedded <- isEmbedded field isNullable <- typeIsNullable (fieldType field) outType <- typeShow <$> if not embedded && isNullable then maybeT <$> isoHaskellType (fieldType field) else isoHaskellType (fieldType field) inType <- if isPtr then typeShow <$> foreignType (fieldType field) else typeShow <$> haskellType (fieldType field) transferType <- fieldTransferType (fieldType field) transferConstraint <- fieldTransferTypeConstraint (fieldType field) api <- findAPIByName owner hackageLink <- hackageModuleLink owner let qualifiedAttrName = dotModulePath (moduleLocation owner api) <> "." <> labelName field attrInfoURL = hackageLink <> "#" <> haddockAttrAnchor <> labelName field line $ "data " <> it line $ "instance AttrInfo " <> it <> " where" indent $ do line $ "type AttrBaseTypeConstraint " <> it <> " = (~) " <> on line $ "type AttrAllowedOps " <> it <> if embedded then " = '[ 'AttrGet]" else if isPtr then " = '[ 'AttrSet, 'AttrGet, 'AttrClear]" else " = '[ 'AttrSet, 'AttrGet]" line $ "type AttrSetTypeConstraint " <> it <> " = (~) " <> if T.any (== ' ') inType then parenthesize inType else inType line $ "type AttrTransferTypeConstraint " <> it <> " = " <> transferConstraint line $ "type AttrTransferType " <> it <> " = " <> transferType line $ "type AttrGetType " <> it <> " = " <> outType line $ "type AttrLabel " <> it <> " = \"" <> fieldName field <> "\"" line $ "type AttrOrigin " <> it <> " = " <> on line $ "attrGet = " <> fieldGetter owner field line $ "attrSet = " <> if not embedded then fieldSetter owner field else "undefined" line $ "attrConstruct = undefined" line $ "attrClear = " <> if not embedded && isPtr then fieldClear owner field else "undefined" if not embedded then do line $ "attrTransfer _ v = do" indent $ genFieldTransfer "v" (fieldType field) else line $ "attrTransfer = undefined" line $ "dbgAttrInfo = P.Just (O.ResolvedSymbolInfo {" indent $ do line $ "O.resolvedSymbolName = \"" <> qualifiedAttrName <> "\"" line $ ", O.resolvedSymbolURL = \"" <> attrInfoURL <> "\"" line $ "})" blank group $ do let labelProxy = lcFirst on <> "_" <> lcFirst (fName field) line $ labelProxy <> " :: AttrLabelProxy \"" <> lcFirst (fName field) <> "\"" line $ labelProxy <> " = AttrLabelProxy" export (NamedSubsection PropertySection $ lcFirst $ fName field) labelProxy return $ "'(\"" <> labelName field <> "\", " <> it <> ")" -- | Build code for a single field. buildFieldAttributes :: Name -> Field -> ExcCodeGen (Maybe Text) buildFieldAttributes n field | not (fieldVisible field) = return Nothing | privateType (fieldType field) = return Nothing | otherwise = group $ do -- We don't generate bindings for private and class structs, so -- do not generate bindings for fields pointing to class structs -- either. ignored <- isIgnoredStructType (fieldType field) when ignored $ notImplementedError "Field type is an unsupported struct type" nullPtr <- nullPtrForType (fieldType field) embedded <- isEmbedded field addSectionDocumentation docSection (fieldDocumentation field) buildFieldReader n field export docSection (fieldGetter n field) when (not embedded) $ do buildFieldWriter n field export docSection (fieldSetter n field) case nullPtr of Just null -> do buildFieldClear n field null export docSection (fieldClear n field) Nothing -> return () Just <$> cppIf CPPOverloading (genAttrInfo n field) where privateType :: Type -> Bool privateType (TInterface n) = "Private" `T.isSuffixOf` name n privateType _ = False docSection = NamedSubsection PropertySection $ lcFirst $ fName field -- | Generate code for the given list of fields. genStructOrUnionFields :: Name -> [Field] -> CodeGen e () genStructOrUnionFields n fields = do let name' = upperName n attrs <- forM fields $ \field -> handleCGExc (\e -> do line ("-- XXX Skipped attribute for \"" <> name' <> ":" <> fieldName field <> "\"") printCGError e return Nothing) (buildFieldAttributes n field) blank cppIf CPPOverloading $ do let attrListName = name' <> "AttributeList" line $ "instance O.HasAttributeList " <> name' line $ "type instance O.AttributeList " <> name' <> " = " <> attrListName line $ "type " <> attrListName <> " = ('[ " <> T.intercalate ", " (catMaybes attrs) <> "] :: [(Symbol, DK.Type)])" -- | Generate a constructor for a zero-filled struct/union of the given -- type, using the boxed (or GLib, for unboxed types) allocator. genZeroSU :: Name -> Int -> Bool -> CodeGen e () genZeroSU n size isBoxed = group $ do let name = upperName n let builder = "newZero" <> name tsize = tshow size writeHaddock DocBeforeSymbol ("Construct a `" <> name <> "` struct initialized to zero.") line $ builder <> " :: MonadIO m => m " <> name line $ builder <> " = liftIO $ " <> if isBoxed then "callocBoxedBytes " <> tsize <> " >>= wrapBoxed " <> name else "boxedPtrCalloc >>= wrapPtr " <> name exportDecl builder blank -- Overloaded "new" group $ do line $ "instance tag ~ 'AttrSet => Constructible " <> name <> " tag where" indent $ do line $ "new _ attrs = do" indent $ do line $ "o <- " <> builder line $ "GI.Attributes.set o attrs" line $ "return o" -- | Specialization for structs of `genZeroSU`. genZeroStruct :: Name -> Struct -> CodeGen e () genZeroStruct n s = when (allocCalloc (structAllocationInfo s) /= AllocationOp "none" && structSize s /= 0) $ genZeroSU n (structSize s) (structIsBoxed s) -- | Specialization for unions of `genZeroSU`. genZeroUnion :: Name -> Union -> CodeGen e () genZeroUnion n u = when (allocCalloc (unionAllocationInfo u ) /= AllocationOp "none" && unionSize u /= 0) $ genZeroSU n (unionSize u) (unionIsBoxed u) -- | Construct a import with the given prefix. prefixedForeignImport :: Text -> Text -> Text -> CodeGen e Text prefixedForeignImport prefix symbol prototype = group $ do line $ "foreign import ccall \"" <> symbol <> "\" " <> prefix <> symbol <> " :: " <> prototype return (prefix <> symbol) -- | Generate a GValue instance for @GBoxed@ objects. genBoxedGValueInstance :: Name -> Text -> CodeGen e () genBoxedGValueInstance n get_type_fn = do let name' = upperName n doc = "Convert '" <> name' <> "' to and from 'Data.GI.Base.GValue.GValue'. See 'Data.GI.Base.GValue.toGValue' and 'Data.GI.Base.GValue.fromGValue'." writeHaddock DocBeforeSymbol doc group $ do bline $ "instance B.GValue.IsGValue (Maybe " <> name' <> ") where" indent $ group $ do line $ "gvalueGType_ = " <> get_type_fn line $ "gvalueSet_ gv P.Nothing = B.GValue.set_boxed gv (FP.nullPtr :: FP.Ptr " <> name' <> ")" line $ "gvalueSet_ gv (P.Just obj) = B.ManagedPtr.withManagedPtr obj (B.GValue.set_boxed gv)" line $ "gvalueGet_ gv = do" indent $ group $ do line $ "ptr <- B.GValue.get_boxed gv :: IO (Ptr " <> name' <> ")" line $ "if ptr /= FP.nullPtr" line $ "then P.Just <$> B.ManagedPtr.newBoxed " <> name' <> " ptr" line $ "else return P.Nothing" -- | Allocation and deallocation for types registered as `GBoxed` in -- the GLib type system. genBoxed :: Name -> Text -> CodeGen e () genBoxed n typeInit = do let name' = upperName n get_type_fn = "c_" <> typeInit group $ do line $ "foreign import ccall \"" <> typeInit <> "\" " <> get_type_fn <> " :: " indent $ line "IO GType" group $ do line $ "type instance O.ParentTypes " <> name' <> " = '[]" bline $ "instance O.HasParentTypes " <> name' group $ do bline $ "instance B.Types.TypedObject " <> name' <> " where" indent $ line $ "glibType = " <> get_type_fn group $ do bline $ "instance B.Types.GBoxed " <> name' genBoxedGValueInstance n get_type_fn -- | Generate the typeclass with information for how to -- allocate/deallocate a given type which is not a `GBoxed`. genWrappedPtr :: Name -> AllocationInfo -> Int -> CodeGen e () genWrappedPtr n info size = group $ do let prefix = \op -> "_" <> name' <> "_" <> op <> "_" when (size == 0 && allocFree info == AllocationOpUnknown) $ line $ "-- XXX Wrapping a foreign struct/union with no known destructor or size, leak?" copy <- case allocCopy info of AllocationOp op -> do copy <- prefixedForeignImport (prefix "copy") op "Ptr a -> IO (Ptr a)" return ("\\p -> B.ManagedPtr.withManagedPtr p (" <> copy <> " >=> B.ManagedPtr.wrapPtr " <> name' <> ")") AllocationOpUnknown -> if size > 0 then return ("\\p -> B.ManagedPtr.withManagedPtr p (copyBytes " <> tshow size <> " >=> B.ManagedPtr.wrapPtr " <> name' <> ")") else return "return" free <- case allocFree info of AllocationOp op -> do free <- prefixedForeignImport (prefix "free") op "Ptr a -> IO ()" return $ "\\p -> B.ManagedPtr.withManagedPtr p " <> free AllocationOpUnknown -> if size > 0 then return "\\x -> SP.withManagedPtr x SP.freeMem" else return "\\_x -> return ()" bline $ "instance BoxedPtr " <> name' <> " where" indent $ do line $ "boxedPtrCopy = " <> copy line $ "boxedPtrFree = " <> free case allocCalloc info of AllocationOp "none" -> return () AllocationOp op -> do calloc <- prefixedForeignImport (prefix "calloc") op "IO (Ptr a)" callocInstance calloc AllocationOpUnknown -> if size > 0 then do let calloc = "callocBytes " <> tshow size callocInstance calloc else return () where name' = upperName n callocInstance :: Text -> CodeGen e () callocInstance calloc = group $ do bline $ "instance CallocPtr " <> name' <> " where" indent $ do line $ "boxedPtrCalloc = " <> calloc haskell-gi-0.26.12/lib/Data/GI/CodeGen/SymbolNaming.hs0000644000000000000000000002524307346545000020256 0ustar0000000000000000{-# LANGUAGE ViewPatterns #-} module Data.GI.CodeGen.SymbolNaming ( lowerName , lowerSymbol , upperName , escapedArgName , classConstraint , typeConstraint , safeCast , hyphensToCamelCase , underscoresToCamelCase , callbackCType , callbackHTypeWithClosures , callbackDropClosures , callbackDynamicWrapper , callbackWrapperAllocator , callbackHaskellToForeign , callbackHaskellToForeignWithClosures , callbackClosureGenerator , signalHaskellName , signalInfoName , submoduleLocation , moduleLocation , qualifiedAPI , qualifiedSymbol , normalizedAPIName , hackageModuleLink , haddockSignalAnchor , haddockAttrAnchor ) where #if !MIN_VERSION_base(4,11,0) import Data.Monoid ((<>)) #endif import Data.Text (Text) import qualified Data.Text as T import Data.GI.CodeGen.API import Data.GI.CodeGen.Code (CodeGen, qualified, getAPI, findAPIByName, config) import Data.GI.CodeGen.Config (Config(..)) import Data.GI.CodeGen.ModulePath (ModulePath, (/.), toModulePath, dotModulePath) import Data.GI.CodeGen.Type (Type(TInterface)) import Data.GI.CodeGen.Util (lcFirst, ucFirst, modifyQualified) -- | Return a qualified form of the constraint for the given name -- (which should correspond to a valid `TInterface`). classConstraint :: Name -> CodeGen e Text classConstraint n@(Name _ s) = qualifiedSymbol ("Is" <> s) n -- | Return a qualified form of the function mapping instances of -- @IsX@ to haskell values of type @X@. safeCast :: Name -> CodeGen e Text safeCast n@(Name _ s) = qualifiedSymbol ("to" <> ucFirst s) n -- | Same as `classConstraint`, but applicable directly to a type. The -- type should be a `TInterface`, otherwise an error will be raised. typeConstraint :: Type -> CodeGen e Text typeConstraint (TInterface n) = classConstraint n typeConstraint t = error $ "Class constraint for non-interface type: " <> show t -- | Foreign type associated with a callback type. It can be passed in -- qualified. callbackCType :: Text -> Text callbackCType = modifyQualified ("C_" <>) -- | Haskell type exposing the closure arguments, which are generally -- elided. callbackHTypeWithClosures :: Text -> Text callbackHTypeWithClosures = modifyQualified (<> "_WithClosures") -- | The name of the dynamic wrapper for the given callback type. It -- can be passed in qualified. callbackDynamicWrapper :: Text -> Text callbackDynamicWrapper = modifyQualified ("dynamic_" <>) -- | The name of the Haskell to foreign wrapper for the given callback -- type. It can be passed in qualified. callbackHaskellToForeign :: Text -> Text callbackHaskellToForeign = modifyQualified ("wrap_" <>) -- | The name of the Haskell to foreign wrapper for the given callback -- type, keeping the closure arguments (we usually elide them). The -- callback type can be passed in qualified. callbackHaskellToForeignWithClosures :: Text -> Text callbackHaskellToForeignWithClosures = modifyQualified ("with_closures_" <>) -- | The name of a function which takes a callback without closure -- arguments, and generates a function which does accep the closures, -- but simply ignores them. callbackDropClosures :: Text -> Text callbackDropClosures = modifyQualified ("drop_closures_" <>) -- | The name for the foreign wrapper allocator (@foreign import -- "wrapper" ...@) for the given callback type. It can be passed in -- qualified. callbackWrapperAllocator :: Text -> Text callbackWrapperAllocator = modifyQualified ("mk_" <>) -- | The name for the closure generator for the given callback -- type. It can be passed in qualified. callbackClosureGenerator :: Text -> Text callbackClosureGenerator = modifyQualified ("genClosure_" <>) -- | Move leading underscores to the end. -- -- === Examples -- >>> sanitize "_Value_Data_Union" -- "Value_Data_Union_" sanitize :: Text -> Text sanitize (T.uncons -> Just ('_', xs)) = sanitize xs <> "_" sanitize xs = xs -- | Same as `lowerSymbol`, but accepts a `Name`. The namespace part -- of the name will be discarded. -- -- === __Examples__ -- >>> lowerName (Name "Gtk" "main_quit") -- "mainQuit" lowerName :: Name -> Text lowerName (Name _ s) = lowerSymbol s -- | Turn the given identifier into camelCase, starting with a -- lowercase letter. -- -- === __Examples__ -- >>> lowerSymbol "main_quit" -- "mainQuit" lowerSymbol :: Text -> Text lowerSymbol s = case underscoresToCamelCase (sanitize s) of "" -> error "empty name!!" n -> lcFirst n -- | Turn the given `Name` into CamelCase, starting with a capital letter. -- -- === __Examples__ -- >>> upperName (Name "Foo" "bar_baz") -- "BarBaz" upperName :: Name -> Text upperName (Name _ s) = underscoresToCamelCase (sanitize s) -- | Construct the submodule path where the given API element will -- live. This is the path relative to the root for the corresponding -- namespace. I.e. the "GI.Gtk" part is not prepended. submoduleLocation :: Name -> API -> ModulePath submoduleLocation _ (APIConst _) = "Constants" submoduleLocation _ (APIFunction _) = "Functions" submoduleLocation _ (APICallback _) = "Callbacks" submoduleLocation _ (APIEnum _) = "Enums" submoduleLocation _ (APIFlags _) = "Flags" submoduleLocation n (APIInterface _) = "Interfaces" /. upperName n submoduleLocation n (APIObject _) = "Objects" /. upperName n submoduleLocation n (APIStruct _) = "Structs" /. upperName n submoduleLocation n (APIUnion _) = "Unions" /. upperName n -- | Obtain the absolute location of the module where the given `API` -- lives. moduleLocation :: Name -> API -> ModulePath moduleLocation n api = ("GI" /. ucFirst (namespace n)) <> submoduleLocation n api -- | Construct the Haskell version of the name associated to the given -- API. normalizedAPIName :: API -> Name -> Name normalizedAPIName (APIConst _) (Name ns name) = Name ns (ucFirst name) normalizedAPIName (APIFunction _) n = n normalizedAPIName (APICallback _) n@(Name ns _) = Name ns (upperName n) normalizedAPIName (APIEnum _) n@(Name ns _) = Name ns (upperName n) normalizedAPIName (APIFlags _) n@(Name ns _) = Name ns (upperName n) normalizedAPIName (APIInterface _) n@(Name ns _) = Name ns (upperName n) normalizedAPIName (APIObject _) n@(Name ns _) = Name ns (upperName n) normalizedAPIName (APIStruct _) n@(Name ns _) = Name ns (upperName n) normalizedAPIName (APIUnion _) n@(Name ns _) = Name ns (upperName n) -- | Return an identifier for the given interface type valid in the current -- module. qualifiedAPI :: API -> Name -> CodeGen e Text qualifiedAPI api n@(Name ns _) = let normalized = normalizedAPIName api n in qualified (toModulePath (ucFirst ns) <> submoduleLocation n api) normalized -- | Construct an identifier for the given symbol in the given API. qualifiedSymbol :: Text -> Name -> CodeGen e Text qualifiedSymbol s n@(Name ns _) = do api <- getAPI (TInterface n) qualified (toModulePath (ucFirst ns) <> submoduleLocation n api) (Name ns s) -- | Turn a hyphen-separated identifier into camel case. -- -- === __Examples__ -- >>> hyphensToCamelCase "one-sample-string" -- "OneSampleString" hyphensToCamelCase :: Text -> Text hyphensToCamelCase = T.concat . map ucFirst . T.split (== '-') -- | Similarly to `hyphensToCamelCase`, turn a name -- separated_by_underscores into CamelCase. We preserve final and -- initial underscores, and n>1 consecutive underscores are -- transformed into n-1 underscores. -- -- === __Examples__ -- >>> underscoresToCamelCase "sample_id" -- "SampleId" -- -- >>> underscoresToCamelCase "_internal_id_" -- "_InternalId_" -- -- >>> underscoresToCamelCase "multiple___underscores" -- "Multiple__Underscores" underscoresToCamelCase :: Text -> Text underscoresToCamelCase = T.concat . map normalize . map ucFirst . T.split (== '_') where normalize :: Text -> Text normalize "" = "_" normalize s = s -- | Name for the given argument, making sure it is a valid Haskell -- argument name (and escaping it if not). escapedArgName :: Arg -> Text escapedArgName arg | argCName arg == "_" = "_'" -- "_" denotes a hole, so we need to escape it | "_" `T.isPrefixOf` argCName arg = argCName arg | otherwise = escapeReserved . lcFirst . underscoresToCamelCase . argCName $ arg -- | Reserved symbols, either because they are Haskell syntax or -- because the clash with symbols in scope for the generated bindings. escapeReserved :: Text -> Text 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 = s <> "_" | "get_" `T.isPrefixOf` s = s <> "_" | otherwise = s -- | Qualified name for the "(sigName, info)" tag for a given signal. signalInfoName :: Name -> Signal -> CodeGen e Text signalInfoName n signal = do let infoName = upperName n <> (ucFirst . signalHaskellName . sigName) signal <> "SignalInfo" qualifiedSymbol infoName n -- | Return the name for the signal in Haskell CamelCase conventions. signalHaskellName :: Text -> Text signalHaskellName sn = case T.split (== '-') sn of [] -> "" -- Won't happen due to the -- definition of T.split, but GHC -- does not know this. w:ws -> w <> T.concat (map ucFirst ws) -- | Return a link to the hackage package for the given name. Note -- that the generated link will only be valid if the name belongs to -- the binding which is currently being generated. hackageModuleLink :: Name -> CodeGen e Text hackageModuleLink n = do api <- findAPIByName n cfg <- config let location = T.replace "." "-" $ dotModulePath (moduleLocation n api) pkg = ghcPkgName cfg <> "-" <> ghcPkgVersion cfg return $ "https://hackage.haskell.org/package/" <> pkg <> "/docs/" <> location <> ".html" -- | Prefix in Haddock for the signal anchor. haddockSignalAnchor :: Text haddockSignalAnchor = "g:signal:" -- | Prefix in Haddock for the attribute anchor. haddockAttrAnchor :: Text haddockAttrAnchor = "g:attr:" haskell-gi-0.26.12/lib/Data/GI/CodeGen/Transfer.hs0000644000000000000000000002641507346545000017445 0ustar0000000000000000-- Routines dealing with memory management in marshalling functions. module Data.GI.CodeGen.Transfer ( freeInArg , freeInArgOnError , freeContainerType ) where #if !MIN_VERSION_base(4,8,0) import Control.Applicative ((<$>), (<*>)) #endif import Control.Monad (when) #if !MIN_VERSION_base(4,11,0) import Data.Monoid ((<>)) #endif import Data.Text (Text) import Data.GI.CodeGen.API import Data.GI.CodeGen.Code import Data.GI.CodeGen.Conversions import Data.GI.CodeGen.GObject import Data.GI.CodeGen.Type import Data.GI.CodeGen.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 Text basicFreeFn (TBasicType TUTF8) = Just "freeMem" basicFreeFn (TBasicType TFileName) = Just "freeMem" basicFreeFn (TBasicType _) = Nothing basicFreeFn (TInterface _) = Nothing -- Just passed along basicFreeFn (TCArray False (-1) (-1) (TBasicType TUInt8)) = Nothing 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 (TGValue) = Nothing basicFreeFn (TParamSpec) = Nothing basicFreeFn (TGClosure _) = 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 e (Maybe Text) 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 TGValue transfer = return $ if transfer == TransferEverything then Just "SP.freeMem" else Nothing basicFreeFnOnError (TGClosure _) transfer = return $ if transfer == TransferEverything then Just "B.GClosure.unrefGClosure" 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 -- Just passed along basicFreeFnOnError (TCArray False (-1) (-1) (TBasicType TUInt8)) _ = 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 -> Text -> CodeGen e [Text] freeContainer t label = case basicFreeFn t of Nothing -> return [] Just fn -> return [fn <> " " <> label] -- Free one element using the given free function. freeElem :: Type -> Text -> Text -> ExcCodeGen Text 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 -> Text -> ExcCodeGen (Maybe Text) 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 -> Text -> Transfer -> ExcCodeGen (Maybe Text) 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 -> Text -> Text -> ExcCodeGen [Text] 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 -> Text -> Text -> 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 -> Text -> 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 -> Text -> Text -> ExcCodeGen [Text] 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 -> Text -> Text -> ExcCodeGen [Text] 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 -> Text -> Text -> ExcCodeGen [Text] 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 -> Text -> ExcCodeGen [Text] freeInGHashTable TransferEverything _ = return [] freeInGHashTable TransferContainer label = notImplementedError $ "Hash table argument with TransferContainer? " <> label freeInGHashTable TransferNothing label = return ["unrefGHashTable " <> label] freeOut :: Text -> CodeGen e [Text] 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 -> Text -> Text -> ExcCodeGen [Text] freeInArg arg label len = do -- Arguments that we alloc ourselves do not always need to be freed, -- they will sometimes be soaked up by the wrapPtr constructor, or -- they will be DirectionIn. if willWrap arg then return [] else case direction arg of DirectionIn -> freeIn (transfer arg) (argType arg) label len DirectionOut -> freeOut label DirectionInout -> freeOut label -- Whether memory ownership of the pointer passed in to the function -- will be assumed by the C->Haskell wrapper. where willWrap :: Arg -> Bool willWrap = argCallerAllocates -- | 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 -> Text -> Text -> ExcCodeGen [Text] freeInArgOnError arg label len = case direction arg of DirectionIn -> freeInOnError (transfer arg) (argType arg) label len DirectionOut -> freeOut label DirectionInout -> -- Caller-allocates arguments are like "in" arguments for -- memory management purposes. if argCallerAllocates arg then freeInOnError (transfer arg) (argType arg) label len else freeOut label haskell-gi-0.26.12/lib/Data/GI/CodeGen/Type.hs0000644000000000000000000000465707346545000016606 0ustar0000000000000000-- | An abstraction for representing type constructors. This is a very -- simplified version of `Data.Typeable`, which we don't use directly -- to avoid compatibility headaches. module Data.GI.CodeGen.Type ( Type(..) -- Reexported for convenience. , BasicType(..) , TypeRep , con , con0 , typeShow , typeConName , io , ptr , funptr , maybeT ) where #if !MIN_VERSION_base(4,11,0) import Data.Monoid ((<>)) #endif import qualified Data.Text as T import Data.Text (Text) import Data.GI.GIR.BasicTypes (Type(..), BasicType(..)) -- | A fully applied type. data TypeRep = TypeRep { typeCon :: TypeCon , typeConArgs :: [TypeRep] } deriving (Eq) -- | A type constructor. We single out some specific constructors -- since they have special syntax in their Haskell representation. data TypeCon = TupleCon | ListCon | TextualCon Text deriving (Eq) -- | Give a valid Haskell source representation of the given -- `TypeRep`. typeShow :: TypeRep -> Text typeShow (TypeRep TupleCon args) = "(" <> T.intercalate ", " (map typeShow args) <> ")" typeShow (TypeRep ListCon args) = "[" <> T.intercalate ", " (map typeShow args) <> "]" typeShow (TypeRep (TextualCon con) args) = T.intercalate " " (con : map (parenthesize . typeShow) args) where parenthesize :: Text -> Text parenthesize s = if T.any (== ' ') s then "(" <> s <> ")" else s -- | Return a textual representation of the type constructor for the -- given `TypeRep`. typeConName :: TypeRep -> Text typeConName (TypeRep TupleCon _) = "(,)" typeConName (TypeRep ListCon _) = "[,]" typeConName (TypeRep (TextualCon s) _) = s -- | Type constructor applied to the given types. con :: Text -> [TypeRep] -> TypeRep con "[]" xs = TypeRep {typeCon = ListCon, typeConArgs = xs } con "(,)" xs = TypeRep {typeCon = TupleCon, typeConArgs = xs } con s xs = TypeRep {typeCon = TextualCon s, typeConArgs = xs} -- | A shorthand for a type constructor taking no arguments. con0 :: Text -> TypeRep con0 c = con c [] -- | Embed in the `IO` monad. io :: TypeRep -> TypeRep io t = "IO" `con` [t] -- | A `Ptr` to the type. ptr :: TypeRep -> TypeRep ptr t = "Ptr" `con` [t] -- | A `FunPtr` to the type. funptr :: TypeRep -> TypeRep funptr t = "FunPtr" `con` [t] -- | Embed in the `Maybe` monad. maybeT :: TypeRep -> TypeRep maybeT t = "Maybe" `con` [t] haskell-gi-0.26.12/lib/Data/GI/CodeGen/Util.hs0000644000000000000000000000723407346545000016574 0ustar0000000000000000module Data.GI.CodeGen.Util ( prime , parenthesize , padTo , withComment , ucFirst , lcFirst , modifyQualified , tshow , terror , utf8ReadFile , utf8WriteFile , splitOn , printWarning ) where import GHC.Stack (HasCallStack) #if !MIN_VERSION_base(4,13,0) import Data.Monoid ((<>)) #endif import Data.Char (toLower, toUpper) import qualified Data.ByteString as B import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Encoding as TE import qualified Data.Text.IO as TIO import qualified System.Console.ANSI as A import System.IO (stderr, hFlush) padTo :: Int -> Text -> Text padTo n s = s <> T.replicate (n - T.length s) " " withComment :: Text -> Text -> Text withComment a b = padTo 40 a <> "-- " <> b prime :: Text -> Text prime = (<> "'") parenthesize :: Text -> Text parenthesize s = "(" <> s <> ")" -- | Construct the `Text` representation of a showable. tshow :: Show a => a -> Text tshow = T.pack . show -- | Capitalize the first character of the given string. ucFirst :: Text -> Text ucFirst "" = "" ucFirst t = T.cons (toUpper $ T.head t) (T.tail t) -- | Make the first character of the given string lowercase. lcFirst :: Text -> Text lcFirst "" = "" lcFirst t = T.cons (toLower $ T.head t) (T.tail t) -- | Apply the given modification function to the given symbol. If the -- symbol is qualified the modification will only apply to the last -- component. modifyQualified :: (Text -> Text) -> Text -> Text modifyQualified f = T.intercalate "." . modify . T.splitOn "." where modify :: [Text] -> [Text] modify [] = [] modify (a:[]) = f a : [] modify (a:as) = a : modify as -- | Split a list into sublists delimited by the given element. splitOn :: Eq a => a -> [a] -> [[a]] splitOn x xs = go xs [] where go [] acc = [reverse acc] go (y : ys) acc = if x == y then reverse acc : go ys [] else go ys (y : acc) -- | Read a file assuming it is UTF-8 encoded. If decoding fails this -- calls `error`. utf8ReadFile :: FilePath -> IO T.Text utf8ReadFile fname = do bytes <- B.readFile fname case TE.decodeUtf8' bytes of Right text -> return text Left error -> terror ("Input file " <> tshow fname <> " seems not to be valid UTF-8. Error was:\n" <> tshow error) -- | Write the given `Text` into an UTF-8 encoded file. utf8WriteFile :: FilePath -> T.Text -> IO () utf8WriteFile fname text = B.writeFile fname (TE.encodeUtf8 text) -- | Print a (colored) warning message to stderr printWarning :: Text -> IO () printWarning warning = do inColour <- A.hSupportsANSIColor stderr if not inColour then TIO.hPutStrLn stderr warning else do A.hSetSGR stderr [A.SetConsoleIntensity A.BoldIntensity, A.SetColor A.Foreground A.Vivid A.Yellow] TIO.hPutStr stderr "Warning: " A.hSetSGR stderr [A.SetColor A.Foreground A.Vivid A.White] TIO.hPutStrLn stderr warning A.hSetSGR stderr [A.Reset] hFlush stderr -- | Throw an error with the given `Text`. terror :: HasCallStack => Text -> a terror errMsg = let fmt = A.setSGRCode [A.SetConsoleIntensity A.BoldIntensity, A.SetColor A.Foreground A.Vivid A.Red] ++ "ERROR: " ++ A.setSGRCode [A.SetColor A.Foreground A.Vivid A.White] ++ T.unpack errMsg ++ A.setSGRCode [A.SetConsoleIntensity A.NormalIntensity, A.SetColor A.Foreground A.Vivid A.Blue] ++ "\nPlease report this at https://github.com/haskell-gi/haskell-gi/issues" ++ A.setSGRCode [A.Reset] in error fmt haskell-gi-0.26.12/lib/Data/GI/GIR/0000755000000000000000000000000007346545000014432 5ustar0000000000000000haskell-gi-0.26.12/lib/Data/GI/GIR/Alias.hs0000644000000000000000000000275207346545000016025 0ustar0000000000000000module Data.GI.GIR.Alias ( documentListAliases ) where import qualified Data.Map as M import Data.Maybe (fromMaybe) import Data.Text (Text) import qualified Data.Text as T import Text.XML (Element(elementAttributes), Document(documentRoot)) import Data.GI.GIR.BasicTypes (Alias(..), Type(..), BasicType(..)) import Data.GI.GIR.Type (parseOptionalType) import Data.GI.GIR.Parser import Data.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 (Name 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 <- parseOptionalType return (name, fromMaybe (TBasicType TPtr) 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) haskell-gi-0.26.12/lib/Data/GI/GIR/Allocation.hs0000644000000000000000000000213307346545000017052 0ustar0000000000000000-- | Information on explicit allocation/deallocation for foreign pointers. module Data.GI.GIR.Allocation ( AllocationInfo(..) , AllocationOp(..) , unknownAllocationInfo ) where import Data.Text (Text) -- | Allocation/deallocation information for a given foreign pointer. data AllocationInfo = AllocationInfo { allocCalloc :: AllocationOp , allocCopy :: AllocationOp , allocFree :: AllocationOp } deriving (Show) -- | Information about a given allocation operation. It is either disallowed, -- allowed via the given function, or it is unknown at the current -- stage how to perform the operation. data AllocationOp = AllocationOpUnknown | AllocationOp Text deriving (Show, Eq) -- | A convenience function, filling in all the allocation info to unknown. unknownAllocationInfo :: AllocationInfo unknownAllocationInfo = AllocationInfo { allocCalloc = AllocationOpUnknown , allocCopy = AllocationOpUnknown , allocFree = AllocationOpUnknown } haskell-gi-0.26.12/lib/Data/GI/GIR/Arg.hs0000644000000000000000000000710607346545000015503 0ustar0000000000000000module Data.GI.GIR.Arg ( Arg(..) , Direction(..) , Scope(..) , parseArg , parseTransfer , parseTransferString ) where #if !MIN_VERSION_base(4,11,0) import Data.Monoid ((<>)) #endif import Data.Text (Text) import Data.GI.GIR.BasicTypes (Transfer(..), Type) import Data.GI.GIR.Parser import Data.GI.GIR.Type (parseType) data Direction = DirectionIn | DirectionOut | DirectionInout deriving (Show, Eq, Ord) data Scope = ScopeTypeInvalid | ScopeTypeCall | ScopeTypeAsync | ScopeTypeNotified | ScopeTypeForever deriving (Show, Eq, Ord) data Arg = Arg { argCName :: Text, -- ^ "C" name for the argument. For a -- escaped name valid in Haskell code, use -- `GI.SymbolNaming.escapedArgName`. argType :: Type, direction :: Direction, mayBeNull :: Bool, argDoc :: Documentation, argScope :: Scope, argClosure :: Int, argDestroy :: Int, argCallerAllocates :: Bool, argCallbackUserData :: Bool, -- ^ Whether the argument is an "user-data" argument for a callback. transfer :: Transfer } deriving (Show, Eq, Ord) parseTransferString :: Text -> Parser Transfer parseTransferString transfer = case transfer of "none" -> return TransferNothing "container" -> return TransferContainer "full" -> return TransferEverything t -> parseError $ "Unknown transfer type \"" <> t <> "\"" parseTransfer :: Parser Transfer parseTransfer = getAttr "transfer-ownership" >>= parseTransferString parseScope :: Text -> Parser Scope parseScope "call" = return ScopeTypeCall parseScope "async" = return ScopeTypeAsync parseScope "notified" = return ScopeTypeNotified parseScope "forever" = return ScopeTypeForever parseScope s = parseError $ "Unknown scope type \"" <> s <> "\"" parseDirection :: Text -> Parser Direction parseDirection "in" = return DirectionIn parseDirection "out" = return DirectionOut parseDirection "inout" = return DirectionInout parseDirection d = parseError $ "Unknown direction \"" <> d <> "\"" parseArg :: Parser Arg parseArg = do name <- getAttr "name" ownership <- parseTransfer scope <- optionalAttr "scope" ScopeTypeInvalid parseScope d <- optionalAttr "direction" DirectionIn parseDirection closure <- optionalAttr "closure" (-1) parseIntegral destroy <- optionalAttr "destroy" (-1) parseIntegral nullable <- optionalAttr "nullable" False parseBool allowNone <- optionalAttr "allow-none" False parseBool -- "allow-none" is deprecated, but still produced by Vala. Support -- it for in arguments. let mayBeNull = if d == DirectionIn then nullable || allowNone else nullable callerAllocates <- optionalAttr "caller-allocates" False parseBool -- There is no annotation for this one yet, see -- https://gitlab.gnome.org/GNOME/gobject-introspection/-/issues/450 -- We will use some heuristics later for setting this field. let callbackUserData = False t <- parseType doc <- parseDocumentation return $ Arg { argCName = name , argType = t , argDoc = doc , direction = d , mayBeNull = mayBeNull , argScope = scope , argClosure = closure , argDestroy = destroy , argCallerAllocates = callerAllocates , argCallbackUserData = callbackUserData , transfer = ownership } haskell-gi-0.26.12/lib/Data/GI/GIR/BasicTypes.hs0000644000000000000000000000611707346545000017041 0ustar0000000000000000-- | Basic types used in GIR parsing. module Data.GI.GIR.BasicTypes ( Name(..) , Transfer(..) , Alias(..) , Type(..) , BasicType(..) ) where import Data.Text (Text) -- | Name for a symbol in the GIR file. data Name = Name { namespace :: Text, name :: Text } 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 Name deriving (Ord, Eq, Show) -- | Basic types. These are generally trivial to marshal, and the GIR -- assumes that they are defined. data BasicType = TBoolean -- ^ gboolean | TInt -- ^ gint | TUInt -- ^ guint | TLong -- ^ glong | TULong -- ^ gulong | TInt8 -- ^ gint8 | TUInt8 -- ^ guint8 | TInt16 -- ^ gint16 | TUInt16 -- ^ guint16 | TInt32 -- ^ gint32 | TUInt32 -- ^ guint32 | TInt64 -- ^ gint64 | TUInt64 -- ^ guint64 | TFloat -- ^ gfloat | TDouble -- ^ gdouble | TUniChar -- ^ gunichar | TGType -- ^ GType | TUTF8 -- ^ gchar*, encoded as UTF-8 | TFileName -- ^ gchar*, encoding a filename | TPtr -- ^ gpointer | TIntPtr -- ^ gintptr | TUIntPtr -- ^ guintptr | TShort -- ^ gshort | TUShort -- ^ gushort | TSize -- ^ gsize | TSSize -- ^ gssize | Ttime_t -- ^ time_t | Toff_t -- ^ off_t | Tdev_t -- ^ dev_t | Tgid_t -- ^ gid_t | Tpid_t -- ^ pid_t | Tsocklen_t -- ^ socklen_t | Tuid_t -- ^ uid_t deriving (Eq, Show, Ord) -- | This type represents the types found in GObject Introspection -- interfaces: the types of constants, arguments, etc. data Type = TBasicType BasicType | TError -- ^ GError | TVariant -- ^ GVariant | TGValue -- ^ GValue | TParamSpec -- ^ GParamSpec | TCArray Bool Int Int Type -- ^ Zero terminated, Array Fixed -- Size, Array Length, Element Type | TGArray Type -- ^ GArray | TPtrArray Type -- ^ GPtrArray | TByteArray -- ^ GByteArray | TGList Type -- ^ GList | TGSList Type -- ^ GSList | TGHash Type Type -- ^ GHashTable | TGClosure (Maybe Type) -- ^ GClosure containing the given API (if known) | TInterface Name -- ^ A reference to some API in the GIR deriving (Eq, Show, Ord) haskell-gi-0.26.12/lib/Data/GI/GIR/Callable.hs0000644000000000000000000000601107346545000016463 0ustar0000000000000000module Data.GI.GIR.Callable ( Callable(..) , parseCallable ) where import Data.GI.GIR.Arg (Arg(..), parseArg, parseTransfer) import Data.GI.GIR.BasicTypes (Transfer(..), Type) import Data.GI.GIR.Parser import Data.GI.GIR.Type (parseOptionalType) data Callable = Callable { returnType :: Maybe Type, returnMayBeNull :: Bool, returnTransfer :: Transfer, returnDocumentation :: Documentation, args :: [Arg], skipReturn :: Bool, callableThrows :: Bool, callableDeprecated :: Maybe DeprecationInfo, callableDocumentation :: Documentation, -- | Whether the symbol for this callable can be resolved in -- the dynamical library associated with the current -- introspection data. 'Nothing' means that we have not -- checked yet. callableResolvable :: Maybe Bool } deriving (Show, Eq) parseArgs :: Parser [Arg] parseArgs = do paramSets <- parseChildrenWithLocalName "parameters" parseArgSet case paramSets of [] -> return [] (ps:[]) -> return ps _ -> parseError $ "Unexpected multiple \"parameters\" tag" where parseArgSet = parseChildrenWithLocalName "parameter" parseArg parseOneReturn :: Parser (Maybe Type, Bool, Transfer, Bool, Documentation) parseOneReturn = do returnType <- parseOptionalType allowNone <- optionalAttr "allow-none" False parseBool nullable <- optionalAttr "nullable" False parseBool transfer <- parseTransfer doc <- parseDocumentation skip <- optionalAttr "skip" False parseBool return (returnType, allowNone || nullable, transfer, skip, doc) parseReturn :: Parser (Maybe Type, Bool, Transfer, Bool, Documentation) parseReturn = do returnSets <- parseChildrenWithLocalName "return-value" parseOneReturn case returnSets of (r:[]) -> return r [] -> parseError $ "No return information found" _ -> parseError $ "Multiple return values found" parseCallable :: Parser Callable parseCallable = do args <- parseArgs (returnType, mayBeNull, transfer, skip, returnDoc) <- parseReturn deprecated <- parseDeprecation docs <- parseDocumentation throws <- optionalAttr "throws" False parseBool return $ Callable { returnType = returnType , returnMayBeNull = mayBeNull , returnTransfer = transfer , returnDocumentation = returnDoc , args = args , skipReturn = skip , callableThrows = throws , callableDeprecated = deprecated , callableDocumentation = docs -- Some symbols are present in the @.gir@ file, but -- they are absent from the library -- itself. Generating bindings for such symbols -- could then lead to linker errors, so later on we -- check whether the callables are actually -- resolvable, and adjust the callable info -- appropriately. , callableResolvable = Nothing } haskell-gi-0.26.12/lib/Data/GI/GIR/Callback.hs0000644000000000000000000000137007346545000016463 0ustar0000000000000000-- | Parsing of callbacks. module Data.GI.GIR.Callback ( Callback(..) , parseCallback ) where import Data.Text (Text) import Data.GI.GIR.Callable (Callable, parseCallable) import Data.GI.GIR.Parser import Data.GI.GIR.Type (queryCType) data Callback = Callback { cbCallable :: Callable , cbCType :: Maybe Text , cbDocumentation :: Documentation } deriving Show parseCallback :: Parser (Name, Callback) parseCallback = do name <- parseName callable <- parseCallable ctype <- queryCType doc <- parseDocumentation return (name, Callback { cbCallable = callable , cbCType = ctype , cbDocumentation = doc }) haskell-gi-0.26.12/lib/Data/GI/GIR/Constant.hs0000644000000000000000000000250307346545000016557 0ustar0000000000000000-- | Parsing of constants in GIR files. module Data.GI.GIR.Constant ( Constant(..) , parseConstant ) where import Data.Text (Text) import Data.GI.GIR.BasicTypes (Type) import Data.GI.GIR.Type (parseType) import Data.GI.GIR.Parser -- | Info about a constant. data Constant = Constant { constantType :: Type, constantValue :: Text, constantCType :: Text, constantDocumentation :: Documentation, 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 -- This contains the C name for the constant. The C gir generator -- call this "c:type", while the vala gir generator calls it -- "c:identifier", so try both. ctype <- queryAttrWithNamespace CGIRNS "type" >>= \case Just i -> return i Nothing -> getAttrWithNamespace CGIRNS "identifier" doc <- parseDocumentation return (name, Constant { constantType = t , constantValue = value , constantCType = ctype , constantDocumentation = doc , constantDeprecated = deprecated }) haskell-gi-0.26.12/lib/Data/GI/GIR/Deprecation.hs0000644000000000000000000000171407346545000017226 0ustar0000000000000000module Data.GI.GIR.Deprecation ( DeprecationInfo(..) , queryDeprecated ) where import qualified Data.Map as M import Data.Text (Text) import Text.XML (Element(elementAttributes)) import Data.GI.GIR.XMLUtils (firstChildWithLocalName, getElementContent) -- | Deprecation information on a symbol. data DeprecationInfo = DeprecationInfo { deprecatedSinceVersion :: Maybe Text, deprecationMessage :: Maybe Text } deriving (Show, Eq) -- | 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 haskell-gi-0.26.12/lib/Data/GI/GIR/Documentation.hs0000644000000000000000000000174507346545000017606 0ustar0000000000000000-- | Parsing of documentation nodes. module Data.GI.GIR.Documentation ( Documentation(..) , queryDocumentation ) where import Data.Text (Text) import Text.XML (Element) import Data.GI.GIR.XMLUtils (firstChildWithLocalName, getElementContent, lookupAttr) -- | Documentation for a given element. The documentation text is -- typically encoded in the gtk-doc format, see -- https://developer.gnome.org/gtk-doc-manual/ . This can be parsed -- with `Data.GI.GIR.parseGtkDoc`. data Documentation = Documentation { rawDocText :: Maybe Text , sinceVersion :: Maybe Text } deriving (Show, Eq, Ord) -- | Parse the documentation node for the given element of the GIR file. queryDocumentation :: Element -> Documentation queryDocumentation element = Documentation { rawDocText = firstChildWithLocalName "doc" element >>= getElementContent, sinceVersion = lookupAttr "version" element } haskell-gi-0.26.12/lib/Data/GI/GIR/Enum.hs0000644000000000000000000000441607346545000015677 0ustar0000000000000000-- | Parsing of Enums. module Data.GI.GIR.Enum ( Enumeration(..) , EnumerationMember(..) , parseEnum ) where import Data.Int (Int64) import Data.Text (Text) import Foreign.C (CInt(..)) import Data.GI.GIR.Parser import Data.GI.GIR.Type (parseCType) data Enumeration = Enumeration { enumMembers :: [EnumerationMember], enumErrorDomain :: Maybe Text, enumTypeInit :: Maybe Text, enumDocumentation :: Documentation, enumCType :: Text, enumStorageBytes :: Int, -- ^ Bytes used for storage of this struct. enumDeprecated :: Maybe DeprecationInfo } deriving Show -- | Member of an enumeration. data EnumerationMember = EnumerationMember { enumMemberName :: Text, enumMemberValue :: Int64, enumMemberCId :: Text, enumMemberDoc :: Documentation } deriving Show -- | Parse a struct member. parseEnumMember :: Parser EnumerationMember parseEnumMember = do name <- getAttr "name" value <- getAttr "value" >>= parseIntegral cid <- getAttrWithNamespace CGIRNS "identifier" doc <- parseDocumentation return $ EnumerationMember { enumMemberName = name, enumMemberValue = value, enumMemberCId = cid, enumMemberDoc = doc } 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 ctype <- parseCType doc <- parseDocumentation deprecated <- parseDeprecation errorDomain <- queryAttrWithNamespace GLibGIRNS "error-domain" typeInit <- queryAttrWithNamespace GLibGIRNS "get-type" members <- parseChildrenWithLocalName "member" parseEnumMember return (name, Enumeration { enumMembers = members , enumErrorDomain = errorDomain , enumDocumentation = doc , enumTypeInit = typeInit , enumCType = ctype , enumStorageBytes = extractEnumStorageBytes (map enumMemberValue members) , enumDeprecated = deprecated }) haskell-gi-0.26.12/lib/Data/GI/GIR/Field.hs0000644000000000000000000000716607346545000016023 0ustar0000000000000000-- | Parsing of object/struct/union fields. module Data.GI.GIR.Field ( Field(..) , FieldInfoFlag , parseFields ) where import Control.Monad.Except (catchError, throwError) import Data.Maybe (isJust, catMaybes) #if !MIN_VERSION_base(4,11,0) import Data.Monoid ((<>)) #endif import Data.Text (Text, isSuffixOf) import Data.GI.GIR.BasicTypes (Type(..)) import Data.GI.GIR.Callback (Callback, parseCallback) import Data.GI.GIR.Type (parseType, queryElementCType) import Data.GI.GIR.Parser data Field = Field { fieldName :: Text, fieldVisible :: Bool, fieldType :: Type, fieldIsPointer :: Maybe Bool, -- ^ `Nothing` if not known. fieldCallback :: Maybe Callback, fieldOffset :: Int, fieldFlags :: [FieldInfoFlag], fieldDocumentation :: Documentation, 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 (Maybe 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 doc <- parseDocumentation -- Sometimes fields marked as not introspectable contain invalid -- introspection info. We are lenient in these cases with parsing -- errors, and simply ignore the fields. flip catchError (\e -> if not introspectable then return Nothing else throwError e) $ do (t, isPtr, 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, isPtr) <- case cbn of Nothing -> do t <- parseType ct <- queryElementCType return (t, fmap ("*" `isSuffixOf`) ct) Just n -> return (TInterface n, Nothing) return (t, isPtr, callback) else do callbacks <- parseAllChildrenWithLocalName "callback" parseName case callbacks of [] -> do t <- parseType ct <- queryElementCType return (t, fmap ("*" `isSuffixOf`) ct, Nothing) [n] -> return (TInterface n, Just True, Nothing) _ -> parseError "Multiple callbacks in field" return $ Just $ Field { fieldName = name , fieldVisible = introspectable && not private , fieldType = t , fieldIsPointer = if isJust callback then Just True else isPtr , fieldCallback = callback , fieldOffset = error ("unfixed field offset " ++ show name) , fieldFlags = flags , fieldDocumentation = doc , fieldDeprecated = deprecated } parseFields :: Parser [Field] parseFields = catMaybes <$> parseAllChildrenWithLocalName "field" parseField haskell-gi-0.26.12/lib/Data/GI/GIR/Flags.hs0000644000000000000000000000065707346545000016032 0ustar0000000000000000-- | 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 Data.GI.GIR.Flags ( Flags(..) , parseFlags ) where import Data.GI.GIR.Enum (Enumeration, parseEnum) import Data.GI.GIR.Parser data Flags = Flags Enumeration deriving Show parseFlags :: Parser (Name, Flags) parseFlags = do (n, enum) <- parseEnum return (n, Flags enum) haskell-gi-0.26.12/lib/Data/GI/GIR/Function.hs0000644000000000000000000000160407346545000016554 0ustar0000000000000000module Data.GI.GIR.Function ( Function(..) , parseFunction ) where import Data.Text (Text) import Data.GI.GIR.Callable (Callable(..), parseCallable) import Data.GI.GIR.Parser data Function = Function { -- | The symbol in the dynlib that this function refers to. fnSymbol :: Text , fnMovedTo :: Maybe Text , fnCallable :: Callable } deriving Show parseFunction :: Parser (Name, Function) parseFunction = do name <- parseName shadows <- queryAttr "shadows" let exposedName = case shadows of Just n -> name {name = n} Nothing -> name callable <- parseCallable symbol <- getAttrWithNamespace CGIRNS "identifier" movedTo <- queryAttr "moved-to" return $ (exposedName, Function { fnSymbol = symbol , fnCallable = callable , fnMovedTo = movedTo }) haskell-gi-0.26.12/lib/Data/GI/GIR/Interface.hs0000644000000000000000000000343707346545000016675 0ustar0000000000000000module Data.GI.GIR.Interface ( Interface(..) , parseInterface ) where import Data.Text (Text) import Data.GI.GIR.Allocation (AllocationInfo, unknownAllocationInfo) import Data.GI.GIR.Method (Method, MethodType(..), parseMethod) import Data.GI.GIR.Property (Property, parseProperty) import Data.GI.GIR.Signal (Signal, parseSignal) import Data.GI.GIR.Parser import Data.GI.GIR.Type (queryCType) data Interface = Interface { ifTypeInit :: Maybe Text, ifCType :: Maybe Text, ifDocumentation :: Documentation, ifPrerequisites :: [Name], ifProperties :: [Property], ifSignals :: [Signal], ifMethods :: [Method], ifAllocationInfo :: AllocationInfo, ifDeprecated :: Maybe DeprecationInfo } deriving Show parseInterface :: Parser (Name, Interface) parseInterface = do name <- parseName props <- parseChildrenWithLocalName "property" parseProperty signals <- parseChildrenWithNSName GLibGIRNS "signal" parseSignal typeInit <- queryAttrWithNamespace GLibGIRNS "get-type" methods <- parseChildrenWithLocalName "method" (parseMethod OrdinaryMethod) functions <- parseChildrenWithLocalName "function" (parseMethod MemberFunction) constructors <- parseChildrenWithLocalName "constructor" (parseMethod Constructor) deprecated <- parseDeprecation doc <- parseDocumentation ctype <- queryCType return (name, Interface { ifProperties = props , ifPrerequisites = error ("unfixed interface " ++ show name) , ifSignals = signals , ifTypeInit = typeInit , ifCType = ctype , ifDocumentation = doc , ifMethods = constructors ++ methods ++ functions , ifAllocationInfo = unknownAllocationInfo , ifDeprecated = deprecated }) haskell-gi-0.26.12/lib/Data/GI/GIR/Method.hs0000644000000000000000000000377207346545000016217 0ustar0000000000000000module Data.GI.GIR.Method ( Method(..) , MethodType(..) , parseMethod ) where import Data.Text (Text) import Data.GI.GIR.Arg (Arg, parseArg) import Data.GI.GIR.Callable (Callable(..), parseCallable) import Data.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 { methodName :: Name, -- | The symbol in the dynlib that this method refers to. methodSymbol :: Text, methodType :: MethodType, methodMovedTo :: Maybe Text, methodCallable :: Callable } deriving (Eq, Show) parseInstanceArg :: Parser Arg parseInstanceArg = do instanceInfo <- parseChildrenWithLocalName "parameters" parseInstPars case instanceInfo of [[inst]] -> return inst [] -> parseError $ "No instance-parameter found." _ -> parseError $ "Too many instance parameters." where parseInstPars :: Parser [Arg] parseInstPars = parseChildrenWithLocalName "instance-parameter" parseArg parseMethod :: MethodType -> Parser Method parseMethod mType = do name <- parseName shadows <- queryAttr "shadows" let exposedName = case shadows of Just n -> name {name = n} Nothing -> name callable <- if mType /= OrdinaryMethod then parseCallable else do c <- parseCallable instanceArg <- parseInstanceArg return $ c {args = instanceArg : args c} symbol <- getAttrWithNamespace CGIRNS "identifier" movedTo <- queryAttr "moved-to" return $ Method { methodName = exposedName , methodSymbol = symbol , methodType = mType , methodMovedTo = movedTo , methodCallable = callable } haskell-gi-0.26.12/lib/Data/GI/GIR/Object.hs0000644000000000000000000001170107346545000016174 0ustar0000000000000000-- | Parsing of objects. module Data.GI.GIR.Object ( Object(..) , parseObject ) where #if !MIN_VERSION_base(4,13,0) import Data.Monoid ((<>)) #endif import Data.Text (Text) import Data.GI.GIR.Method (Method, parseMethod, MethodType(..)) import Data.GI.GIR.Property (Property, parseProperty) import Data.GI.GIR.Signal (Signal, parseSignal) import Data.GI.GIR.Parser import Data.GI.GIR.Type (queryCType) data Object = Object { objParent :: Maybe Name, objTypeInit :: Text, objTypeName :: Text, objCType :: Maybe Text, objRefFunc :: Maybe Text, objUnrefFunc :: Maybe Text, objSetValueFunc :: Maybe Text, objGetValueFunc :: Maybe Text, objInterfaces :: [Name], objDeprecated :: Maybe DeprecationInfo, objDocumentation :: Documentation, objMethods :: [Method], objProperties :: [Property], objSignals :: [Signal] } deriving Show parseObject :: Parser (Name, Object) parseObject = do name <- parseName deprecated <- parseDeprecation doc <- parseDocumentation 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 typeInitFn <- getAttrWithNamespace GLibGIRNS "get-type" typeInit <- case typeInitFn of "intern" -> resolveInternalType name fn -> return fn typeName <- getAttrWithNamespace GLibGIRNS "type-name" signals <- parseChildrenWithNSName GLibGIRNS "signal" parseSignal refFunc <- queryAttrWithNamespace GLibGIRNS "ref-func" unrefFunc <- queryAttrWithNamespace GLibGIRNS "unref-func" setValueFunc <- queryAttrWithNamespace GLibGIRNS "set-value-func" getValueFunc <- queryAttrWithNamespace GLibGIRNS "get-value-func" ctype <- queryCType return (name, Object { objParent = parent , objTypeInit = typeInit , objCType = ctype , objRefFunc = refFunc , objUnrefFunc = unrefFunc , objSetValueFunc = setValueFunc , objGetValueFunc = getValueFunc , objTypeName = typeName , objInterfaces = interfaces , objDeprecated = deprecated , objDocumentation = doc , objMethods = constructors ++ methods ++ functions , objProperties = props , objSignals = signals }) -- | Some basic types do not list a type init function, and instead -- mention "intern". Provide the explicit numerical value of the GType -- in these cases. resolveInternalType :: Name -> Parser Text resolveInternalType (Name "GObject" p@"ParamSpec") = pspec_type_init p resolveInternalType (Name "GObject" p@"ParamSpecBoolean") = pspec_type_init p resolveInternalType (Name "GObject" p@"ParamSpecBoxed") = pspec_type_init p resolveInternalType (Name "GObject" p@"ParamSpecChar") = pspec_type_init p resolveInternalType (Name "GObject" p@"ParamSpecDouble") = pspec_type_init p resolveInternalType (Name "GObject" p@"ParamSpecEnum") = pspec_type_init p resolveInternalType (Name "GObject" p@"ParamSpecFlags") = pspec_type_init p resolveInternalType (Name "GObject" p@"ParamSpecFloat") = pspec_type_init p resolveInternalType (Name "GObject" p@"ParamSpecGType") = pspec_type_init p resolveInternalType (Name "GObject" p@"ParamSpecInt") = pspec_type_init p resolveInternalType (Name "GObject" p@"ParamSpecInt64") = pspec_type_init p resolveInternalType (Name "GObject" p@"ParamSpecLong") = pspec_type_init p resolveInternalType (Name "GObject" p@"ParamSpecObject") = pspec_type_init p resolveInternalType (Name "GObject" p@"ParamSpecOverride") = pspec_type_init p resolveInternalType (Name "GObject" p@"ParamSpecParam") = pspec_type_init p resolveInternalType (Name "GObject" p@"ParamSpecPointer") = pspec_type_init p resolveInternalType (Name "GObject" p@"ParamSpecString") = pspec_type_init p resolveInternalType (Name "GObject" p@"ParamSpecUChar") = pspec_type_init p resolveInternalType (Name "GObject" p@"ParamSpecUInt") = pspec_type_init p resolveInternalType (Name "GObject" p@"ParamSpecUInt64") = pspec_type_init p resolveInternalType (Name "GObject" p@"ParamSpecULong") = pspec_type_init p resolveInternalType (Name "GObject" p@"ParamSpecUnichar") = pspec_type_init p resolveInternalType (Name "GObject" p@"ParamSpecVariant") = pspec_type_init p resolveInternalType (Name "GObject" p@"ParamSpecValueArray") = pspec_type_init p resolveInternalType (Name ns n) = parseError $ "Unknown internal type: " <> ns <> "." <> n <> "\n" <> "This is a bug, please report at https://github.com/haskell-gi/haskell-gi/issues" -- | The name of the function we provide for querying ParamSpec types -- at runtime. pspec_type_init :: Text -> Parser Text pspec_type_init p = return $ "haskell_gi_pspec_type_init_" <> p haskell-gi-0.26.12/lib/Data/GI/GIR/Parser.hs0000644000000000000000000002065007346545000016225 0ustar0000000000000000-- | The Parser monad. module Data.GI.GIR.Parser ( Parser , ParseContext(..) , ParseError , parseError , runParser , parseName , parseDeprecation , parseDocumentation , parseIntegral , parseBool , parseChildrenWithLocalName , parseAllChildrenWithLocalName , parseChildrenWithNSName , getAttr , getAttrWithNamespace , queryAttr , queryAttrWithNamespace , optionalAttr , currentNamespace , qualifyName , resolveQualifiedTypeName -- Reexported for convenience , Name(..) , Element , GIRXMLNamespace(..) , DeprecationInfo , Documentation ) where import Control.Monad.Except import Control.Monad.Reader #if !MIN_VERSION_base(4,11,0) import Data.Monoid ((<>)) #endif 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 Data.GI.GIR.BasicTypes (Name(..), Alias(..), Type(TInterface)) import Data.GI.GIR.Deprecation (DeprecationInfo, queryDeprecated) import Data.GI.GIR.Documentation (Documentation, queryDocumentation) import Data.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 (ctxNamespace ctx) 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 :: Name -> Parser Type resolveQualifiedTypeName name = do ctx <- ask case M.lookup (Alias name) (knownAliases ctx) of -- The resolved type may be an alias itself, like for -- Gtk.Allocation -> Gdk.Rectangle -> cairo.RectangleInt Just (TInterface n) -> resolveQualifiedTypeName n Just t -> return t Nothing -> return $ TInterface name -- | 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 ns 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 the documentation info for the current node. parseDocumentation :: Parser Documentation parseDocumentation = do ctx <- ask return $ queryDocumentation (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 } haskell-gi-0.26.12/lib/Data/GI/GIR/Property.hs0000644000000000000000000000401007346545000016605 0ustar0000000000000000module Data.GI.GIR.Property ( Property(..) , PropertyFlag(..) , parseProperty ) where import Data.Text (Text) #if !MIN_VERSION_base(4,11,0) import Data.Monoid ((<>)) #endif import Data.GI.GIR.Arg (parseTransferString) import Data.GI.GIR.BasicTypes (Transfer(..), Type) import Data.GI.GIR.Parser import Data.GI.GIR.Type (parseType) data PropertyFlag = PropertyReadable | PropertyWritable | PropertyConstruct | PropertyConstructOnly deriving (Show,Eq) data Property = Property { propName :: Text, propType :: Type, propFlags :: [PropertyFlag], propReadNullable :: Maybe Bool, propWriteNullable :: Maybe Bool, propTransfer :: Transfer, propDoc :: Documentation, propDeprecated :: Maybe DeprecationInfo } deriving (Show, Eq) parseProperty :: Parser Property parseProperty = do name <- getAttr "name" t <- parseType transfer <- optionalAttr "transfer-ownership" TransferNothing parseTransferString deprecated <- parseDeprecation readable <- optionalAttr "readable" True parseBool writable <- optionalAttr "writable" False parseBool construct <- optionalAttr "construct" False parseBool constructOnly <- optionalAttr "construct-only" False parseBool maybeNullable <- optionalAttr "nullable" Nothing (\t -> Just <$> parseBool t) let flags = (if readable then [PropertyReadable] else []) <> (if writable then [PropertyWritable] else []) <> (if construct then [PropertyConstruct] else []) <> (if constructOnly then [PropertyConstructOnly] else []) doc <- parseDocumentation return $ Property { propName = name , propType = t , propFlags = flags , propTransfer = transfer , propDeprecated = deprecated , propDoc = doc , propReadNullable = maybeNullable , propWriteNullable = maybeNullable } haskell-gi-0.26.12/lib/Data/GI/GIR/Repository.hs0000644000000000000000000000724707346545000017157 0ustar0000000000000000module Data.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 qualified Text.XML as XML import System.Directory import System.Environment (lookupEnv) import System.Environment.XDG.BaseDir (getSystemDataDirs) import System.FilePath (searchPathSeparator, takeBaseName, (), (<.>)) 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 -- | Split a list into sublists delimited by the given element. splitOn :: Eq a => a -> [a] -> [[a]] splitOn x xs = go xs [] where go [] acc = [reverse acc] go (y : ys) acc = if x == y then reverse acc : go ys [] else go ys (y : acc) -- | Return the paths where to look for gir files. girDataDirs :: IO [FilePath] girDataDirs = do sys <- getSystemDataDirs "gir-1.0" -- See https://github.com/haskell-gi/haskell-gi/issues/390 let macOS = ["/opt/homebrew/share/gir-1.0"] return (sys ++ macOS) -- | Construct the GIR search path, possibly looking into the -- @HASKELL_GI_GIR_SEARCH_PATH@ environment variable if no explicit -- list of extra paths is given. In either case -- the system data dirs are also searched if nothing can be found in -- the explicitly passed paths, or in the contents of -- @HASKELL_GI_GIR_SEARCH_PATH@. buildSearchPath :: [FilePath] -> IO [FilePath] buildSearchPath extraPaths = do paths <- case extraPaths of [] -> lookupEnv "HASKELL_GI_GIR_SEARCH_PATH" >>= \case Nothing -> return [] Just s -> return (splitOn searchPathSeparator s) ps -> return ps dataDirs <- girDataDirs return (paths ++ dataDirs) -- | Search for an appropriate @.gir@ file in the search path. girFile :: Text -> Maybe Text -> [FilePath] -> IO (Maybe FilePath) girFile name version searchPath = firstJust <$> (mapM (girFile' name version) searchPath) where firstJust = listToMaybe . catMaybes -- | Try to load the `.gir` file corresponding to the given repository readGiRepository :: Bool -- ^ verbose -> Text -- ^ name -> Maybe Text -- ^ version -> [FilePath] -- ^ searchPath -> IO XML.Document readGiRepository verbose name version extraPaths = do searchPath <- buildSearchPath extraPaths girFile name version searchPath >>= \case Just path -> do when verbose $ putStrLn $ "Loading GI repository: " ++ path XML.readFile XML.def path Nothing -> error $ "Did not find a GI repository for " ++ (T.unpack name) ++ maybe "" ("-" ++) (T.unpack <$> version) ++ " in " ++ show searchPath ++ "." haskell-gi-0.26.12/lib/Data/GI/GIR/Signal.hs0000644000000000000000000000147207346545000016207 0ustar0000000000000000module Data.GI.GIR.Signal ( Signal(..) , parseSignal ) where import Data.Text (Text) import Data.GI.GIR.Callable (Callable(..), parseCallable) import Data.GI.GIR.Parser data Signal = Signal { sigName :: Text, sigCallable :: Callable, sigDeprecated :: Maybe DeprecationInfo, sigDetailed :: Bool, sigDoc :: Documentation } deriving (Show, Eq) parseSignal :: Parser Signal parseSignal = do n <- getAttr "name" detailed <- optionalAttr "detailed" False parseBool deprecated <- parseDeprecation callable <- parseCallable doc <- parseDocumentation return $ Signal { sigName = n , sigCallable = callable , sigDeprecated = deprecated , sigDetailed = detailed , sigDoc = doc } haskell-gi-0.26.12/lib/Data/GI/GIR/Struct.hs0000644000000000000000000000437607346545000016264 0ustar0000000000000000-- | Parsing of structs. module Data.GI.GIR.Struct ( Struct(..) , parseStruct ) where import Data.Text (Text) import Data.GI.GIR.Allocation (AllocationInfo(..), unknownAllocationInfo) import Data.GI.GIR.Field (Field, parseFields) import Data.GI.GIR.Method (Method, MethodType(..), parseMethod) import Data.GI.GIR.Parser import Data.GI.GIR.Type (queryCType) data Struct = Struct { structIsBoxed :: Bool, structAllocationInfo :: AllocationInfo, structTypeInit :: Maybe Text, structCType :: Maybe Text, structSize :: Int, gtypeStructFor :: Maybe Name, -- https://bugzilla.gnome.org/show_bug.cgi?id=560248 structIsDisguised :: Bool, structForceVisible :: Bool, structFields :: [Field], structMethods :: [Method], structDeprecated :: Maybe DeprecationInfo, structDocumentation :: Documentation } deriving Show parseStruct :: Parser (Name, Struct) parseStruct = do name <- parseName deprecated <- parseDeprecation doc <- parseDocumentation structFor <- queryAttrWithNamespace GLibGIRNS "is-gtype-struct-for" >>= \case Just t -> (fmap Just . qualifyName) t Nothing -> return Nothing typeInit <- queryAttrWithNamespace GLibGIRNS "get-type" maybeCType <- queryCType disguised <- optionalAttr "disguised" False parseBool forceVisible <- optionalAttr "haskell-gi-force-visible" False parseBool fields <- parseFields constructors <- parseChildrenWithLocalName "constructor" (parseMethod Constructor) methods <- parseChildrenWithLocalName "method" (parseMethod OrdinaryMethod) functions <- parseChildrenWithLocalName "function" (parseMethod MemberFunction) return (name, Struct { structIsBoxed = error ("[boxed] unfixed struct " ++ show name) , structAllocationInfo = unknownAllocationInfo , structTypeInit = typeInit , structCType = maybeCType , structSize = error ("[size] unfixed struct " ++ show name) , gtypeStructFor = structFor , structIsDisguised = disguised , structForceVisible = forceVisible , structFields = fields , structMethods = constructors ++ methods ++ functions , structDeprecated = deprecated , structDocumentation = doc }) haskell-gi-0.26.12/lib/Data/GI/GIR/Type.hs0000644000000000000000000001716307346545000015717 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE RecordWildCards, PatternGuards #-} -- | Parsing type information from GIR files. module Data.GI.GIR.Type ( parseType , queryCType , parseCType , queryElementCType , parseOptionalType ) where #include "HsBaseConfig.h" import Data.Maybe (catMaybes) #if !MIN_VERSION_base(4,11,0) import Data.Monoid ((<>)) #endif import Data.Text (Text) import qualified Data.Text as T import Data.GI.GIR.BasicTypes (Type(..), BasicType(..)) import Data.GI.GIR.Parser -- | Map the given type name to a `BasicType` (defined in -- Data.GI.GIR.BasicTypes), if possible. nameToBasicType :: Text -> Maybe BasicType nameToBasicType "gpointer" = Just TPtr nameToBasicType "gboolean" = Just TBoolean nameToBasicType "gchar" = Just TInt8 nameToBasicType "gint" = Just TInt nameToBasicType "guint" = Just TUInt nameToBasicType "glong" = Just TLong nameToBasicType "gulong" = Just TULong 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 "gintptr" = Just TIntPtr nameToBasicType "guintptr" = Just TUIntPtr nameToBasicType "gshort" = Just TShort nameToBasicType "gushort" = Just TUShort nameToBasicType "gssize" = Just TSSize nameToBasicType "gsize" = Just TSize nameToBasicType "time_t" = Just Ttime_t nameToBasicType "off_t" = Just Toff_t nameToBasicType "dev_t" = Just Tdev_t nameToBasicType "gid_t" = Just Tgid_t nameToBasicType "pid_t" = Just Tpid_t nameToBasicType "socklen_t" = Just Tsocklen_t nameToBasicType "uid_t" = Just Tuid_t 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 [] -> return $ TGHash (TBasicType TPtr) (TBasicType TPtr) [Just key, Just value] -> return $ TGHash key value other -> parseError $ "Unsupported hash type: " <> T.pack (show other) -- | Parse a `GClosure` declaration. parseClosure :: Parser Type parseClosure = queryAttr "closure-type" >>= \case Just t -> (TGClosure . Just) <$> parseTypeName t Nothing -> return $ TGClosure Nothing -- | 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 TPtr) -- | 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 parseFundamentalType "GObject" "Value" = return TGValue parseFundamentalType "GObject" "Closure" = parseClosure -- A TInterface type (basically, everything that is not of a known type). parseFundamentalType ns n = resolveQualifiedTypeName (Name ns n) -- | Parse a type given as a string. parseTypeName :: Text -> Parser Type parseTypeName typeName = 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 <> "\"" -- | Parse information on a "type" element. Returns either a `Type`, -- or `Nothing` indicating that the name of the type in the -- introspection data was "none" (associated with @void@ in C). parseTypeInfo :: Parser (Maybe Type) parseTypeInfo = do typeName <- getAttr "name" if typeName == "none" then return Nothing else Just <$> parseTypeName typeName -- | Find the children giving the type of the given element. parseTypeElements :: Parser [Maybe Type] parseTypeElements = do types <- parseChildrenWithLocalName "type" parseTypeInfo arrays <- parseChildrenWithLocalName "array" parseArrayInfo return (types ++ map Just arrays) -- | Find the C name for the current element. queryCType :: Parser (Maybe Text) queryCType = queryAttrWithNamespace CGIRNS "type" -- | Parse the C type for the current node. parseCType :: Parser Text parseCType = getAttrWithNamespace CGIRNS "type" -- | Find the children giving the C type for the element. parseCTypeNameElements :: Parser [Text] parseCTypeNameElements = do types <- parseChildrenWithLocalName "type" queryCType arrays <- parseChildrenWithLocalName "array" queryCType return (catMaybes (types ++ arrays)) -- | 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, or if the type name is "none". queryType :: Parser (Maybe Type) queryType = parseTypeElements >>= \case [Just e] -> return (Just e) [] -> return Nothing [Nothing] -> parseError $ "Unexpected \"none\" type." _ -> 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 [Just e] -> return e [] -> parseError $ "Did not find a type for the element." [Nothing] -> parseError $ "Unexpected \"none\" type." _ -> parseError $ "Found more than one type for the element." -- | Like `parseType`, but allow for @none@, returned as `Nothing`. parseOptionalType :: Parser (Maybe Type) parseOptionalType = parseTypeElements >>= \case [e] -> return e [] -> parseError $ "Did not find a type for the element." _ -> parseError $ "Found more than one type for the element." -- | Parse the C-type associated to the element, if found. queryElementCType :: Parser (Maybe Text) queryElementCType = parseCTypeNameElements >>= \case [ctype] -> return (Just ctype) [] -> return Nothing _ -> parseError $ "Found more than one type for the element." haskell-gi-0.26.12/lib/Data/GI/GIR/Union.hs0000644000000000000000000000321207346545000016054 0ustar0000000000000000-- | Parsing of unions. module Data.GI.GIR.Union ( Union(..) , parseUnion ) where import Data.Maybe (isJust) import Data.Text (Text) import Data.GI.GIR.Allocation (AllocationInfo(..), unknownAllocationInfo) import Data.GI.GIR.Field (Field, parseFields) import Data.GI.GIR.Method (Method, MethodType(..), parseMethod) import Data.GI.GIR.Parser import Data.GI.GIR.Type (queryCType) data Union = Union { unionIsBoxed :: Bool, unionAllocationInfo :: AllocationInfo, unionDocumentation :: Documentation, unionSize :: Int, unionTypeInit :: Maybe Text, unionFields :: [Field], unionMethods :: [Method], unionCType :: Maybe Text, unionDeprecated :: Maybe DeprecationInfo } deriving Show parseUnion :: Parser (Name, Union) parseUnion = do name <- parseName deprecated <- parseDeprecation doc <- parseDocumentation typeInit <- queryAttrWithNamespace GLibGIRNS "get-type" fields <- parseFields constructors <- parseChildrenWithLocalName "constructor" (parseMethod Constructor) methods <- parseChildrenWithLocalName "method" (parseMethod OrdinaryMethod) functions <- parseChildrenWithLocalName "function" (parseMethod MemberFunction) ctype <- queryCType return (name, Union { unionIsBoxed = isJust typeInit , unionAllocationInfo = unknownAllocationInfo , unionDocumentation = doc , unionTypeInit = typeInit , unionSize = error ("unfixed union size " ++ show name) , unionFields = fields , unionMethods = constructors ++ methods ++ functions , unionCType = ctype , unionDeprecated = deprecated }) haskell-gi-0.26.12/lib/Data/GI/GIR/XMLUtils.hs0000644000000000000000000000677207346545000016463 0ustar0000000000000000-- | Some helpers for making traversals of GIR documents easier. module Data.GI.GIR.XMLUtils ( nodeToElement , subelements , localName , lookupAttr , GIRXMLNamespace(..) , lookupAttrWithNamespace , childElemsWithLocalName , childElemsWithNSName , firstChildWithLocalName , getElementContent , xmlLocalName , xmlNSName ) 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 | CoreGIRNS 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" girNamespace CoreGIRNS = "http://www.gtk.org/introspection/core/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) -- | Construct a `Text.XML.Name` by only giving the local name. xmlLocalName :: Text -> Name xmlLocalName n = Name { nameLocalName = n , nameNamespace = Nothing , namePrefix = Nothing } -- | Construct a `Text.XML.Name` specifying a namespace too. xmlNSName :: GIRXMLNamespace -> Text -> Name xmlNSName ns n = Name { nameLocalName = n , nameNamespace = Just (girNamespace ns) , namePrefix = Nothing } haskell-gi-0.26.12/lib/c/0000755000000000000000000000000007346545000013063 5ustar0000000000000000haskell-gi-0.26.12/lib/c/enumStorage.c0000644000000000000000000000621307346545000015522 0ustar0000000000000000/* 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 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); } }