haskell-gi-0.21.5/0000755000000000000000000000000000000000000011746 5ustar0000000000000000haskell-gi-0.21.5/ChangeLog.md0000755000000000000000000000424500000000000014127 0ustar0000000000000000### 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.21.5/DocTests.hs0000644000000000000000000000135500000000000014036 0ustar0000000000000000import Test.DocTest import System.Process main :: IO () main = do gobjectIntrospectionLibs <- pkgConfigLibs "gobject-introspection-1.0" doctest $ [ "-XCPP", "-XOverloadedStrings", "-XRankNTypes", "-XLambdaCase" , "-ilib" -- For the autogenerated Data.GI.CodeGen.GType (hsc) , "-idist/build" , "dist/build/lib/c/enumStorage.o" ] ++ gobjectIntrospectionLibs ++ -- The actual modules to test [ "Data.GI.CodeGen.GtkDoc" , "Data.GI.CodeGen.ModulePath" , "Data.GI.CodeGen.SymbolNaming" , "Data.GI.CodeGen.Haddock" ] pkgConfigLibs :: String -> IO [String] pkgConfigLibs pkg = words <$> readProcess "pkg-config" ["--libs", pkg] "" haskell-gi-0.21.5/LICENSE0000644000000000000000000005756400000000000012774 0ustar0000000000000000 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.21.5/Setup.hs0000644000000000000000000000011000000000000013372 0ustar0000000000000000#!/usr/bin/env runhaskell import Distribution.Simple main = defaultMain haskell-gi-0.21.5/haskell-gi.cabal0000644000000000000000000001173500000000000014761 0ustar0000000000000000name: haskell-gi version: 0.21.5 synopsis: Generate Haskell bindings for GObject Introspection capable libraries description: Generate Haskell bindings for GObject Introspection capable libraries. This includes most notably Gtk+, but many other libraries in the GObject ecosystem provide introspection data too. homepage: https://github.com/haskell-gi/haskell-gi license: LGPL-2.1 -- or above license-file: LICENSE author: Will Thompson, Iñaki García Etxebarria, Jonas Platte maintainer: Iñaki García Etxebarria (garetxe@gmail.com) stability: Experimental category: Development build-type: Simple tested-with: GHC == 7.8.4, GHC == 7.10.3, GHC == 8.0.1, GHC == 8.4.1, GHC == 8.6.1 cabal-version: >=1.8 extra-source-files: ChangeLog.md source-repository head type: git location: git://github.com/haskell-gi/haskell-gi.git Library pkgconfig-depends: gobject-introspection-1.0 >= 1.32, gobject-2.0 >= 2.32 build-depends: base >= 4.7 && < 5, haskell-gi-base == 0.21.*, Cabal >= 1.24, attoparsec == 0.13.*, containers, directory, filepath, mtl >= 2.2, transformers >= 0.3, pretty-show, process, safe, bytestring, xdg-basedir, xml-conduit >= 1.3.0, regex-tdfa >= 1.2, text >= 1.0 if !impl(ghc >= 8.0) build-depends: semigroups == 0.18.* extensions: CPP, ForeignFunctionInterface, DoAndIfThenElse, LambdaCase, RankNTypes, OverloadedStrings ghc-options: -Wall -fwarn-incomplete-patterns -fno-warn-name-shadowing if impl(ghc >= 8.0) ghc-options: -Wcompat c-sources: lib/c/enumStorage.c build-tools: 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.Cabal, 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.OverloadedLabels, 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 test-suite doctests type: exitcode-stdio-1.0 ghc-options: -threaded main-is: DocTests.hs build-depends: base , process , doctest >= 0.8 haskell-gi-0.21.5/lib/Data/GI/CodeGen/0000755000000000000000000000000000000000000015170 5ustar0000000000000000haskell-gi-0.21.5/lib/Data/GI/CodeGen/API.hs0000644000000000000000000005514200000000000016144 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, forM_) import qualified Data.List as L import qualified Data.Map as M import Data.Maybe (mapMaybe, catMaybes) import Data.Monoid ((<>)) import qualified Data.Set as S import qualified Data.Text as T import Data.Text (Text) import Foreign.Ptr (Ptr) import Foreign (peek) import Foreign.C.Types (CUInt) import Text.XML hiding (Name) import 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, FieldInfo(..), girStructFieldInfo, girUnionFieldInfo, girLoadGType) import Data.GI.CodeGen.GType (gtypeIsBoxed) import Data.GI.CodeGen.Type (Type) data GIRInfo = GIRInfo { girPCPackages :: [Text], girNSName :: Text, girNSVersion :: Text, girAPIs :: [(Name, API)], girCTypes :: M.Map Text Name } deriving Show data GIRNamespace = GIRNamespace { nsName :: Text, nsVersion :: Text, nsAPIs :: [(Name, API)], nsCTypes :: [(Text, Name)] } deriving (Show) data GIRInfoParse = GIRInfoParse { girIPPackage :: [Maybe Text], girIPIncludes :: [Maybe (Text, Text)], girIPNamespaces :: [Maybe GIRNamespace] } deriving (Show) -- | 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. | GIRAddNode GIRPath XML.Name -- ^ Add a child node at -- the given selector. | GIRDeleteNode GIRPath -- ^ Delete any nodes matching -- the given selector. deriving (Show) data API = APIConst Constant | APIFunction Function | APICallback Callback | APIEnum Enumeration | APIFlags Flags | APIInterface Interface | APIObject Object | APIStruct Struct | APIUnion Union deriving Show parseAPI :: Text -> M.Map Alias Type -> Element -> (a -> API) -> Parser (Name, a) -> (Name, API) parseAPI ns aliases element wrapper parser = case runParser ns aliases element parser of Left err -> error $ "Parse error: " ++ T.unpack err Right (n, a) -> (n, wrapper a) parseNSElement :: M.Map Alias Type -> GIRNamespace -> Element -> GIRNamespace parseNSElement aliases ns@GIRNamespace{..} element | lookupAttr "introspectable" element == Just "0" = ns | otherwise = case nameLocalName (elementName element) of "alias" -> ns -- Processed separately "constant" -> parse APIConst parseConstant "enumeration" -> parse APIEnum parseEnum "bitfield" -> parse APIFlags parseFlags "function" -> parse APIFunction parseFunction "callback" -> parse APICallback parseCallback "record" -> parse APIStruct parseStruct "union" -> parse APIUnion parseUnion "class" -> parse APIObject parseObject "interface" -> parse APIInterface parseInterface "boxed" -> ns -- Unsupported n -> error . T.unpack $ "Unknown GIR element \"" <> n <> "\" when processing namespace \"" <> nsName <> "\", aborting." where parse :: (a -> API) -> Parser (Name, a) -> GIRNamespace parse wrapper parser = let (n, api) = parseAPI nsName aliases element wrapper parser maybeCType = lookupAttrWithNamespace CGIRNS "type" element in ns { nsAPIs = (n, api) : nsAPIs, nsCTypes = case maybeCType of Just ctype -> (ctype, n) : nsCTypes Nothing -> nsCTypes } parseNamespace :: Element -> M.Map Alias Type -> Maybe GIRNamespace parseNamespace element aliases = do let attrs = elementAttributes element name <- M.lookup "name" attrs version <- M.lookup "version" attrs let ns = GIRNamespace { nsName = name, nsVersion = version, nsAPIs = [], nsCTypes = [] } return (L.foldl' (parseNSElement aliases) ns (subelements element)) parseInclude :: Element -> Maybe (Text, Text) parseInclude element = do name <- M.lookup "name" attrs version <- M.lookup "version" attrs return (name, version) where attrs = elementAttributes element parsePackage :: Element -> Maybe Text parsePackage element = M.lookup "name" (elementAttributes element) parseRootElement :: M.Map Alias Type -> GIRInfoParse -> Element -> GIRInfoParse parseRootElement aliases info@GIRInfoParse{..} element = case nameLocalName (elementName element) of "include" -> info {girIPIncludes = parseInclude element : girIPIncludes} "package" -> info {girIPPackage = parsePackage element : girIPPackage} "namespace" -> info {girIPNamespaces = parseNamespace element aliases : girIPNamespaces} _ -> info emptyGIRInfoParse :: GIRInfoParse emptyGIRInfoParse = GIRInfoParse { girIPPackage = [], girIPIncludes = [], girIPNamespaces = [] } parseGIRDocument :: M.Map Alias Type -> Document -> GIRInfoParse parseGIRDocument aliases doc = L.foldl' (parseRootElement aliases) emptyGIRInfoParse (subelements (documentRoot doc)) -- | Parse the list of includes in a given document. documentListIncludes :: Document -> S.Set (Text, Text) documentListIncludes doc = S.fromList (mapMaybe parseInclude includes) where includes = childElemsWithLocalName "include" (documentRoot doc) -- | Load a set of dependencies, recursively. loadDependencies :: Bool -- ^ Verbose -> S.Set (Text, Text) -- ^ Requested -> M.Map (Text, Text) Document -- ^ Loaded so far -> [FilePath] -- ^ extra path to search -> [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 <- fixupGIRDocument 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] -- ^ fixups -> IO (Document, M.Map (Text, Text) Document) -- ^ (loaded doc, dependencies) loadGIRFile verbose name version extraPaths rules = do doc <- fixupGIRDocument 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 -- | 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 forM_ (docGIR : depsGIR) $ \info -> girRequire (girNSName info) (girNSVersion info) (fixedDoc, fixedDeps) <- fixupGIRInfos docGIR depsGIR return (fixedDoc, fixedDeps) else error . T.unpack $ "Got unexpected namespace \"" <> girNSName docGIR <> "\" when parsing \"" <> name <> "\"." where combineErrors :: Either Text GIRInfo -> [Either Text GIRInfo] -> Either Text (GIRInfo, [GIRInfo]) combineErrors parsedDoc parsedDeps = do doc <- parsedDoc deps <- sequence parsedDeps return (doc, deps) foreign import ccall "g_type_interface_prerequisites" g_type_interface_prerequisites :: CGType -> Ptr CUInt -> IO (Ptr CGType) -- | List the prerequisites for a 'GType' corresponding to an interface. gtypeInterfaceListPrereqs :: GType -> IO [Text] gtypeInterfaceListPrereqs (GType cgtype) = do nprereqsPtr <- allocMem :: IO (Ptr CUInt) ps <- g_type_interface_prerequisites cgtype nprereqsPtr nprereqs <- peek nprereqsPtr psCGTypes <- unpackStorableArrayWithLength nprereqs ps freeMem ps freeMem nprereqsPtr mapM (fmap T.pack . gtypeName . GType) psCGTypes -- | The list of prerequisites in GIR files is not always -- accurate. Instead of relying on this, we instantiate the 'GType' -- associated to the interface, and listing the interfaces from there. fixupInterface :: M.Map Text Name -> (Name, API) -> IO (Name, API) fixupInterface csymbolMap (n@(Name ns _), APIInterface iface) = do prereqs <- case ifTypeInit iface of Nothing -> return [] Just ti -> do gtype <- girLoadGType ns ti prereqGTypes <- gtypeInterfaceListPrereqs gtype forM prereqGTypes $ \p -> do case M.lookup p csymbolMap of Just pn -> return pn Nothing -> error $ "Could not find prerequisite type " ++ show p ++ " for interface " ++ show n return (n, APIInterface (iface {ifPrerequisites = prereqs})) fixupInterface _ (n, api) = return (n, api) -- | There is not enough info in the GIR files to determine whether a -- struct is boxed. We find out by instantiating the 'GType' -- corresponding to the struct (if known) and checking whether it -- descends from the boxed GType. Similarly, the size of the struct -- and offset of the fields is hard to compute from the GIR data, we -- simply reuse the machinery in libgirepository. fixupStruct :: M.Map Text Name -> (Name, API) -> IO (Name, API) fixupStruct _ (n, APIStruct s) = do fixed <- (fixupStructIsBoxed n >=> fixupStructSizeAndOffsets n) s return (n, APIStruct fixed) fixupStruct _ api = return api -- | Find out whether the struct is boxed. fixupStructIsBoxed :: Name -> Struct -> IO Struct -- The type for "GVariant" is marked as "intern", we wrap -- this one natively. fixupStructIsBoxed (Name "GLib" "Variant") s = return (s {structIsBoxed = False}) fixupStructIsBoxed (Name ns _) s = do isBoxed <- case structTypeInit s of Nothing -> return False Just ti -> do gtype <- girLoadGType ns ti return (gtypeIsBoxed gtype) return (s {structIsBoxed = isBoxed}) -- | Fix the size and alignment of fields. This is much easier to do -- by using libgirepository than reading the GIR file directly. fixupStructSizeAndOffsets :: Name -> Struct -> IO Struct fixupStructSizeAndOffsets (Name ns n) s = do (size, infoMap) <- girStructFieldInfo ns n return (s { structSize = size , structFields = map (fixupField infoMap) (structFields s)}) -- | Same thing for unions. fixupUnion :: M.Map Text Name -> (Name, API) -> IO (Name, API) fixupUnion _ (n, APIUnion u) = do fixed <- (fixupUnionSizeAndOffsets n) u return (n, APIUnion fixed) fixupUnion _ api = return api -- | Like 'fixupStructSizeAndOffset' above. fixupUnionSizeAndOffsets :: Name -> Union -> IO Union fixupUnionSizeAndOffsets (Name ns n) u = do (size, 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 } -- | Fixup parsed GIRInfos: some of the required information is not -- found in the GIR files themselves, but can be obtained by -- instantiating the required GTypes from the installed libraries. fixupGIRInfos :: GIRInfo -> [GIRInfo] -> IO (GIRInfo, [GIRInfo]) fixupGIRInfos doc deps = (fixup fixupInterface >=> fixup fixupStruct >=> fixup fixupUnion) (doc, deps) where fixup :: (M.Map Text Name -> (Name, API) -> IO (Name, API)) -> (GIRInfo, [GIRInfo]) -> IO (GIRInfo, [GIRInfo]) fixup fixer (doc, deps) = do fixedDoc <- fixAPIs fixer doc fixedDeps <- mapM (fixAPIs fixer) deps return (fixedDoc, fixedDeps) fixAPIs :: (M.Map Text Name -> (Name, API) -> IO (Name, API)) -> GIRInfo -> IO GIRInfo fixAPIs fixer info = do fixedAPIs <- mapM (fixer ctypes) (girAPIs info) return $ info {girAPIs = fixedAPIs} ctypes :: M.Map Text Name ctypes = M.unions (map girCTypes (doc:deps)) -- | Given a XML document containing GIR data, apply the given overrides. fixupGIRDocument :: [GIRRule] -> XML.Document -> XML.Document fixupGIRDocument rules doc = doc {XML.documentRoot = fixupGIR 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. fixupGIR :: [GIRRule] -> XML.Element -> XML.Element fixupGIR 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 (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 -- | 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.21.5/lib/Data/GI/CodeGen/Cabal.hs0000644000000000000000000001676500000000000016545 0ustar0000000000000000module Data.GI.CodeGen.Cabal ( genCabalProject , cabalConfig , setupHs , tryPkgConfig ) where #if !MIN_VERSION_base(4,8,0) import Control.Applicative ((<$>), (<*>)) #endif import Control.Monad (forM_) import Data.Maybe (fromMaybe) import Data.Monoid ((<>)) import Data.Version (Version(..)) import qualified Data.Map as M import qualified Data.Text as T import Data.Text (Text) import Text.Read import Data.GI.CodeGen.API (GIRInfo(..)) import Data.GI.CodeGen.Code import Data.GI.CodeGen.Config (Config(..)) import Data.GI.CodeGen.Overrides (cabalPkgVersion) import Data.GI.CodeGen.PkgConfig (pkgConfigGetVersion) import qualified Data.GI.CodeGen.ProjectInfo as PI import Data.GI.CodeGen.Util (padTo, tshow) import Paths_haskell_gi (version) cabalConfig :: Text cabalConfig = T.unlines ["optimization: False"] setupHs :: Text setupHs = T.unlines ["#!/usr/bin/env runhaskell", "import Distribution.Simple", "main = defaultMain"] haskellGIAPIVersion :: Int haskellGIAPIVersion = (head . versionBranch) version -- | Obtain the minor version. That is, if the given version numbers -- are x.y.z, so branch is [x,y,z], we return y. minorVersion :: [Int] -> Int minorVersion (_:y:_) = y minorVersion v = error $ "Programming error: the haskell-gi version does not have at least two components: " ++ show v ++ "." -- | Obtain the haskell-gi minor version. Notice that we only append -- the minor version here, ignoring revisions. (So if the version is -- x.y.z, we drop the "z" part.) This gives us a mechanism for -- releasing bug-fix releases of haskell-gi without increasing the -- necessary dependency on haskell-gi-base, which only depends on x.y. haskellGIMinor :: Int haskellGIMinor = minorVersion (versionBranch version) {- | If the haskell-gi version is of the form x.y[.z] and the pkgconfig version of the package being wrapped is a.b.c, this gives something of the form x.a.b.y. This strange seeming-rule is so that the packages that we produce follow the PVP, assuming that the package being wrapped follows the usual semantic versioning convention (http://semver.org) that increases in "a" indicate non-backwards compatible changes, increases in "b" backwards compatible additions to the API, and increases in "c" denote API compatible changes (so we do not need to regenerate bindings for these, at least in principle, so we do not encode them in the cabal version). In order to follow the PVP, then everything we need to do in the haskell-gi side is to increase x everytime the generated API changes (for a fixed a.b.c version). In any case, if such "strange" package numbers are undesired, or the wrapped package does not follow semver, it is possible to add an explicit cabal-pkg-version override. This needs to be maintained by hand (including in the list of dependencies of packages depending on this one), so think carefully before using this override! -} giModuleVersion :: Int -> Int -> Text giModuleVersion major minor = (T.intercalate "." . map tshow) [haskellGIAPIVersion, major, minor, haskellGIMinor] -- | Determine the next version for which the minor of the package has -- been bumped. giNextMinor :: Int -> Int -> Text giNextMinor major minor = (T.intercalate "." . map tshow) [haskellGIAPIVersion, major, minor+1] -- | Info for a given package. data PkgInfo = PkgInfo { pkgName :: Text , pkgMajor :: Int , pkgMinor :: Int } deriving Show -- | Determine the pkg-config name and installed version (major.minor -- only) for a given module, or throw an exception if that fails. tryPkgConfig :: GIRInfo -> Bool -> M.Map Text Text -> IO (Either Text PkgInfo) tryPkgConfig gir verbose overridenNames = do let name = girNSName gir version = girNSVersion gir packages = girPCPackages gir pkgConfigGetVersion name version packages verbose overridenNames >>= \case Just (n,v) -> case readMajorMinor v of Just (major, minor) -> return $ Right (PkgInfo { pkgName = n , pkgMajor = major , pkgMinor = minor}) Nothing -> return $ Left $ "Cannot parse version \"" <> v <> "\" for module " <> name Nothing -> return $ Left $ "Could not determine the pkg-config name corresponding to \"" <> name <> "\".\n" <> "Try adding an override with the proper package name:\n" <> "pkg-config-name " <> name <> " [matching pkg-config name here]" -- | Given a string a.b.c..., representing a version number, determine -- the major and minor versions, i.e. "a" and "b". If successful, -- return (a,b). readMajorMinor :: Text -> Maybe (Int, Int) readMajorMinor version = case T.splitOn "." version of (a:b:_) -> (,) <$> readMaybe (T.unpack a) <*> readMaybe (T.unpack b) _ -> Nothing -- | Generate the cabal project. genCabalProject :: (GIRInfo, PkgInfo) -> [(GIRInfo, PkgInfo)] -> [Text] -> BaseVersion -> CodeGen () genCabalProject (gir, PkgInfo {pkgName = pcName, pkgMajor = major, pkgMinor = minor}) deps exposedModules minBaseVersion = do cfg <- config let name = girNSName gir line $ "-- Autogenerated, do not edit." line $ padTo 20 "name:" <> "gi-" <> T.toLower name let cabalVersion = fromMaybe (giModuleVersion major minor) (cabalPkgVersion $ overrides cfg) line $ padTo 20 "version:" <> cabalVersion line $ padTo 20 "synopsis:" <> name <> " bindings" line $ padTo 20 "description:" <> "Bindings for " <> name <> ", autogenerated by haskell-gi." line $ padTo 20 "homepage:" <> PI.homepage line $ padTo 20 "license:" <> PI.license line $ padTo 20 "license-file:" <> "LICENSE" line $ padTo 20 "author:" <> PI.authors line $ padTo 20 "maintainer:" <> PI.maintainers line $ padTo 20 "category:" <> PI.category line $ padTo 20 "build-type:" <> "Simple" line $ padTo 20 "cabal-version:" <> ">=1.10" blank line $ "library" indent $ do line $ padTo 20 "default-language:" <> PI.defaultLanguage line $ padTo 20 "default-extensions:" <> T.intercalate ", " PI.defaultExtensions line $ padTo 20 "other-extensions:" <> T.intercalate ", " PI.otherExtensions line $ padTo 20 "ghc-options:" <> T.intercalate " " PI.ghcOptions line $ padTo 20 "exposed-modules:" <> head exposedModules forM_ (tail exposedModules) $ \mod -> line $ padTo 20 "" <> mod line $ padTo 20 "pkgconfig-depends:" <> pcName <> " >= " <> tshow major <> "." <> tshow minor line $ "build-depends:" indent $ do line $ "haskell-gi-base >= " <> tshow haskellGIAPIVersion <> "." <> tshow haskellGIMinor <> " && < " <> tshow (haskellGIAPIVersion + 1) <> "," forM_ deps $ \(dep, PkgInfo _ depMajor depMinor) -> do let depName = girNSName dep line $ "gi-" <> T.toLower depName <> " >= " <> giModuleVersion depMajor depMinor <> " && < " <> giNextMinor depMajor depMinor <> "," forM_ PI.standardDeps (line . (<> ",")) line $ "base >= " <> showBaseVersion minBaseVersion <> " && <5" haskell-gi-0.21.5/lib/Data/GI/CodeGen/CabalHooks.hs0000644000000000000000000000713300000000000017536 0ustar0000000000000000-- | Convenience hooks for writing custom @Setup.hs@ files for -- bindings. module Data.GI.CodeGen.CabalHooks ( setupHaskellGIBinding ) 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) 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 (parseOverridesFile, girFixups, filterAPIsAndDeps) import Data.GI.CodeGen.Util (ucFirst) import Control.Monad (when, void) import Data.Maybe (fromJust, fromMaybe) import qualified Data.Map as M import Data.Text (Text) import qualified Data.Text as T import System.Directory (doesFileExist) import System.FilePath ((), (<.>)) type ConfHook = (GenericPackageDescription, HookedBuildInfo) -> ConfigFlags -> IO LocalBuildInfo -- | 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 -> Bool -- ^ verbose -> Maybe FilePath -- ^ overrides file -> Maybe FilePath -- ^ output dir -> ConfHook -- ^ previous `confHook` -> ConfHook confCodeGenHook name version verbosity overrides outputDir defaultConfHook (gpd, hbi) flags = do setupTypelibSearchPath [] ovs <- case overrides of Nothing -> return mempty Just fname -> parseOverridesFile fname >>= \case Left err -> error $ "Error when parsing overrides file: " ++ T.unpack err Right ovs -> return ovs (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, verbose = verbosity, overrides = ovs} let m = genCode cfg allAPIs (toModulePath name) (genModule apis) let em' = map (MN.fromString . T.unpack) (listModuleTree m) ctd' = ((condTreeData . fromJust . condLibrary) gpd) {exposedModules = em'} cL' = ((fromJust . condLibrary) gpd) {condTreeData = ctd'} gpd' = gpd {condLibrary = Just cL'} alreadyDone <- doesFileExist (fromMaybe "" outputDir "GI" T.unpack (ucFirst name) <.> "hs") when (not alreadyDone) $ do void $ writeModuleTree verbosity outputDir m lbi <- defaultConfHook (gpd', hbi) flags return (lbi {withOptimization = NoOptimisation}) -- | The entry point for @Setup.hs@ files in bindings. setupHaskellGIBinding :: Text -- ^ name -> Text -- ^ version -> Bool -- ^ verbose -> Maybe FilePath -- ^ overrides file -> Maybe FilePath -- ^ output dir -> IO () setupHaskellGIBinding name version verbose overridesFile outputDir = defaultMainWithHooks (simpleUserHooks { confHook = confCodeGenHook name version verbose overridesFile outputDir (confHook simpleUserHooks) }) haskell-gi-0.21.5/lib/Data/GI/CodeGen/Callable.hs0000644000000000000000000012400000000000000017220 0ustar0000000000000000{-# LANGUAGE LambdaCase #-} module Data.GI.CodeGen.Callable ( genCCallableWrapper , genDynamicCallableWrapper , ForeignSymbol(..) , ExposeClosures(..) , hOutType , skipRetVal , arrayLengths , arrayLengthsMap , callableSignature , Signature(..) , fixupCallerAllocates , callableHInArgs , callableHOutArgs , wrapMaybe , inArgInterfaces ) where #if !MIN_VERSION_base(4,8,0) import Control.Applicative ((<$>)) #endif import Control.Monad (forM, forM_, when, void) import Data.Bool (bool) import Data.List (nub, (\\)) import Data.Maybe (isJust) import Data.Monoid ((<>)) 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) -- | Whether to expose closures and the associated destroy notify -- handlers in the Haskell wrapper. data ExposeClosures = WithClosures | WithoutClosures 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 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 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 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] -> ExcCodeGen ([Text], [Text]) inArgInterfaces inArgs = consAndTypes (['a'..'z'] \\ ['m']) inArgs where consAndTypes :: [Char] -> [Arg] -> ExcCodeGen ([Text], [Text]) consAndTypes _ [] = return ([], []) consAndTypes letters (arg:args) = do (ls, t, cons) <- argumentType letters $ argType arg t' <- wrapMaybe arg >>= bool (return t) (return $ "Maybe (" <> t <> ")") (restCons, restTypes) <- consAndTypes ls args return (cons <> restCons, t' : restTypes) -- Given a callable, return a list of (array, length) pairs, where in -- each pair "length" is the argument holding the length of the -- (non-zero-terminated, non-fixed size) C array. arrayLengthsMap :: Callable -> [(Arg, Arg)] -- List of (array, length) arrayLengthsMap callable = go (args callable) [] where go :: [Arg] -> [(Arg, Arg)] -> [(Arg, Arg)] go [] acc = acc go (a:as) acc = case argType a of TCArray False fixedSize length _ -> if fixedSize > -1 || length == -1 then go as acc else go as $ (a, (args callable)!!length) : acc _ -> go as acc -- Return the list of arguments of the callable that contain length -- arguments, including a possible length for the result of calling -- the function. arrayLengths :: Callable -> [Arg] arrayLengths callable = map snd (arrayLengthsMap callable) <> -- Often one of the arguments is just the length of -- the result. case returnType callable of 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 -> ExcCodeGen Text prepareArgForCall omitted arg = 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 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 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 -> CodeGen Text prepareInCallback arg (Callback {cbCallable = cb}) = do let name = escapedArgName arg ptrName = "ptr" <> name scope = argScope arg (maker, wrapper, drop) <- case argType arg of TInterface tn@(Name _ n) -> do drop <- if callableHasClosures cb 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 (castPtrToFunPtr nullPtr)" 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 (TypeAllocInfo isBoxed n) -> do let allocator = if isBoxed then "callocBoxedBytes" else "callocBytes" wrapMaybe arg >>= bool (do name'' <- genConversion (prime name') $ literal $ M $ allocator <> " " <> tshow n <> " :: " <> 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 (TypeAllocInfo isBoxed n) -> do let allocator = if isBoxed then "callocBoxedBytes" else "callocBytes" genConversion name $ literal $ M $ allocator <> " " <> tshow n <> " :: " <> typeShow (io ft) Nothing -> notImplementedError $ ("Don't know how to allocate \"" <> argCName arg <> "\" of type " <> tshow (argType arg)) else genConversion name $ literal $ M $ "allocMem :: " <> 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! " <> T.pack (ppShow callable) <> "\n" <> T.pack (ppShow m) <> "\n" <> tshow closure 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) 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 -> let destroyName = escapedArgName $ (args callable)!!k in line $ "let " <> destroyName <> " = safeFreeFunPtrPtr" ScopeTypeAsync -> line $ "let " <> closureName <> " = nullPtr" ScopeTypeCall -> line $ "let " <> closureName <> " = nullPtr" 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) $ line $ "safeFreeFunPtr $ castFunPtrToPtr " <> name' -- | Format the signature of the Haskell binding for the `Callable`. formatHSignature :: Callable -> ForeignSymbol -> ExcCodeGen () formatHSignature callable symbol = do sig <- callableSignature callable symbol 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 -> ExcCodeGen Signature callableSignature callable symbol = do let (hInArgs, _) = callableHInArgs callable (case symbol of KnownForeignSymbol _ -> WithoutClosures DynamicForeignSymbol _ -> WithClosures) (argConstraints, types) <- inArgInterfaces hInArgs 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 omitted = case expose of WithoutClosures -> arrayLengths callable <> closures <> destroyers 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 () 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 () 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 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) return name -- | Generate the body of the Haskell wrapper for the given foreign symbol. genWrapperBody :: Name -> ForeignSymbol -> Callable -> [Arg] -> [Arg] -> [Arg] -> ExcCodeGen () genWrapperBody n symbol callable hInArgs hOutArgs omitted = do readInArrayLengths n callable hInArgs inArgNames <- forM (args callable) $ \arg -> prepareArgForCall omitted arg -- Map from argument names to names passed to the C function let nameMap = Map.fromList $ flip zip inArgNames $ map 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} 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 () genCallableDebugInfo callable = group $ do line $ "-- Args : " <> (tshow $ args callable) line $ "-- Lengths : " <> (tshow $ arrayLengths callable) line $ "-- returnType : " <> (tshow $ 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?" -- | Generate a wrapper for a known C symbol. genCCallableWrapper :: Name -> Text -> Callable -> ExcCodeGen () genCCallableWrapper n cSymbol callable = 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} -- | 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.21.5/lib/Data/GI/CodeGen/Code.hs0000644000000000000000000011202400000000000016376 0ustar0000000000000000{-# LANGUAGE GeneralizedNewtypeDeriving #-} module Data.GI.CodeGen.Code ( Code , ModuleInfo(moduleCode, sectionDocs) , ModuleFlag(..) , BaseCodeGen , CodeGen , ExcCodeGen , CGError(..) , genCode , evalCodeGen , writeModuleTree , listModuleTree , codeToText , transitiveModuleDeps , minBaseVersion , BaseVersion(..) , showBaseVersion , registerNSDependency , qualified , getDeps , recurseWithAPIs , handleCGExc , describeCGError , notImplementedError , badIntroError , missingInfoError , indent , increaseIndent , bline , line , blank , group , cppIf , CPPGuard(..) , hsBoot , submodule , setLanguagePragmas , setGHCOptions , setModuleFlags , setModuleMinBase , exportModule , exportDecl , export , HaddockSection(..) , NamedSection(..) , addSectionFormattedDocs , findAPI , getAPI , findAPIByName , getAPIs , getC2HMap , config , currentModule ) where #if !MIN_VERSION_base(4,8,0) import Control.Applicative ((<$>)) import Data.Monoid (Monoid(..)) #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) import Data.Monoid ((<>), mempty) 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 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 | 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 | 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. } -- | Clean slate for `CGState`. emptyCGState :: CGState emptyCGState = CGState { cgsCPPConditionals = [] } -- | The base type for the code generator monad. type BaseCodeGen excType a = ReaderT CodeGenConfig (StateT (CGState, ModuleInfo) (Except excType)) a -- | The code generator monad, for generators that cannot throw -- errors. The fact that they cannot throw errors is encoded in the -- forall, which disallows any operation on the error, except -- discarding it or passing it along without inspecting. This last -- operation is useful in order to allow embedding `CodeGen` -- computations inside `ExcCodeGen` computations, while disallowing -- the opposite embedding without explicit error handling. type CodeGen a = forall e. BaseCodeGen e a -- | Code generators that can throw errors. type ExcCodeGen a = BaseCodeGen CGError a -- | Run a `CodeGen` with given `Config` and initial state, returning -- either the resulting exception, or the result and final module info. runCodeGen :: BaseCodeGen 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 :: BaseCodeGen e a -> BaseCodeGen e (a, Code) recurseCG = recurseWithState id -- | Like `recurseCG`, but we allow for explicitly setting the state -- of the inner code generator. recurseWithState :: (CGState -> CGState) -> BaseCodeGen e a -> BaseCodeGen 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 () -> CodeGen () 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 -> BaseCodeGen e () -> BaseCodeGen 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 -> BaseCodeGen e () -> BaseCodeGen 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 a) -> ExcCodeGen a -> CodeGen 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 Deps getDeps = moduleDeps . snd <$> get -- | Return the ambient configuration for the code generator. config :: CodeGen Config config = hConfig <$> ask -- | Return the name of the current module. currentModule :: CodeGen Text currentModule = do (_, s) <- get return (dotWithPrefix (modulePath s)) -- | Return the list of APIs available to the generator. getAPIs :: CodeGen (M.Map Name API) getAPIs = loadedAPIs <$> ask -- | Return the C -> Haskell available to the generator. getC2HMap :: CodeGen (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 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 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 () -> ModuleInfo genCode cfg apis mPath cg = snd $ evalCodeGen cfg apis mPath cg -- | Mark the given dependency as used by the module. registerNSDependency :: Text -> CodeGen () 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 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 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)) -- | Give a friendly textual description of the error for presenting -- to the user. describeCGError :: CGError -> Text describeCGError (CGErrorNotImplemented e) = "Not implemented: " <> tshow e describeCGError (CGErrorBadIntrospectionInfo e) = "Bad introspection data: " <> tshow e describeCGError (CGErrorMissingInfo e) = "Missing info: " <> tshow 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 findAPI :: Type -> CodeGen (Maybe API) findAPI TError = Just <$> findAPIByName (Name "GLib" "Error") 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 :: Type -> CodeGen API getAPI t = findAPI t >>= \case Just a -> return a Nothing -> terror ("Could not resolve type \"" <> tshow t <> "\".") findAPIByName :: Name -> CodeGen 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 () tellCode c = modify' (\(cgs, s) -> (cgs, s {moduleCode = moduleCode s <> codeSingleton c})) -- | Print out a (newline-terminated) line. line :: Text -> CodeGen () line = tellCode . Line -- | Print out the given line both to the normal module, and to the -- HsBoot file. bline :: Text -> CodeGen () bline l = hsBoot (line l) >> line l -- | A blank line blank :: CodeGen () blank = line "" -- | Increase the indent level for code generation. indent :: BaseCodeGen e a -> BaseCodeGen 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 () increaseIndent = tellCode IncreaseIndent -- | Group a set of related code. group :: BaseCodeGen e a -> BaseCodeGen e a group cg = do (x, code) <- recurseCG cg tellCode (Group code) blank return x -- | Guard a block of code with @#if@. cppIfBlock :: Text -> BaseCodeGen e a -> BaseCodeGen 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 = CGState {cgsCPPConditionals = CPPIf cond : cgsCPPConditionals cgs} -- | Possible features to test via CPP. data CPPGuard = CPPOverloading -- ^ Enable overloading -- | Guard a code block with CPP code, such that it is included only -- if the specified feature is enabled. cppIf :: CPPGuard -> BaseCodeGen e a -> BaseCodeGen e a cppIf CPPOverloading = cppIfBlock "ENABLE_OVERLOADING" -- | Write the given code into the .hs-boot file for the current module. hsBoot :: BaseCodeGen e a -> BaseCodeGen 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 () exportPartial partial = modify' $ \(cgs, s) -> (cgs, let e = partial $ cgsCPPConditionals cgs in s{moduleExports = moduleExports s |> e}) -- | Reexport a whole module. exportModule :: SymbolName -> CodeGen () exportModule m = exportPartial (Export ExportModule m) -- | Add a type declaration-related export. exportDecl :: SymbolName -> CodeGen () exportDecl d = exportPartial (Export ExportTypeDecl d) -- | Export a symbol in the given haddock subsection. export :: HaddockSection -> SymbolName -> CodeGen () export s n = exportPartial (Export (ExportSymbol s) n) -- | Set the language pragmas for the current module. setLanguagePragmas :: [Text] -> CodeGen () setLanguagePragmas ps = modify' $ \(cgs, s) -> (cgs, s{modulePragmas = Set.fromList ps}) -- | Set the GHC options for compiling this module (in a OPTIONS_GHC pragma). setGHCOptions :: [Text] -> CodeGen () setGHCOptions opts = modify' $ \(cgs, s) -> (cgs, s{moduleGHCOpts = Set.fromList opts}) -- | Set the given flags for the module. setModuleFlags :: [ModuleFlag] -> CodeGen () setModuleFlags flags = modify' $ \(cgs, s) -> (cgs, s{moduleFlags = Set.fromList flags}) -- | Set the minimum base version supported by the current module. setModuleMinBase :: BaseVersion -> CodeGen () setModuleMinBase v = modify' $ \(cgs, s) -> (cgs, s{moduleMinBase = max v (moduleMinBase s)}) -- | Add documentation for a given section. addSectionFormattedDocs :: HaddockSection -> Text -> CodeGen () addSectionFormattedDocs 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 (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 spaces, and add a -- newline at the end. paddedLine :: Int -> Text -> Text paddedLine n s = T.replicate (n * 4) " " <> s <> "\n" -- | 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 :: NamedSection -> [(Subsection, Export)] -> Maybe Text formatSection section exports = if null exports then Nothing else Just . T.unlines $ [" -- * " <> mainSectionName section , ( T.unlines . map formatSubsection . M.toList ) exportedSubsections] where exportedSubsections :: M.Map Subsection (Set.Set Export) exportedSubsections = foldr extract M.empty exports 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 -> "{- | " <> text <> "\n-}" 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) (M.toAscList collectedExports) where collectedExports :: M.Map NamedSection [(Subsection, Export)] collectedExports = foldl classifyExport M.empty exports classifyExport :: M.Map NamedSection [(Subsection, Export)] -> Export -> M.Map NamedSection [(Subsection, Export)] classifyExport m export = case exportType export of ExportSymbol hs@(NamedSubsection ms n) -> let subsec = subsecWithPrefix ms n (M.lookup hs docs) in M.insertWith (++) ms [(subsec, 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 ["#define ENABLE_OVERLOADING (MIN_VERSION_haskell_gi_overloading(1,0,0) \\" -- Haddocks look better without overloading , " && !defined(__HADDOCK_VERSION__))" ] -- | 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 = T.unlines ["{- |", standardFields <> "-}"] moduleHaddock (Just description) = T.unlines ["{- |", standardFields, description, "-}"] -- | 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 _ [] = "" 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.ManagedPtr as B.ManagedPtr" , "import qualified Data.GI.Base.GError as B.GError" , "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.Text as T" , "import qualified Data.ByteString.Char8 as B" , "import qualified Data.Map as Map" , "import qualified Foreign.Ptr as FP" ] -- | 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 -> IO () writeModuleInfo verbose dirPrefix minfo = 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)) deps = importDeps pkgRoot (Set.toList $ qualifiedImports minfo) 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) -- | 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 minfo = do submodulePaths <- concat <$> forM (M.elems (submodules minfo)) (writeModuleTree verbose dirPrefix) writeModuleInfo verbose dirPrefix minfo return $ (dotWithPrefix (modulePath minfo) : submodulePaths) -- | 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.21.5/lib/Data/GI/CodeGen/CodeGen.hs0000644000000000000000000004251200000000000017034 0ustar0000000000000000module Data.GI.CodeGen.CodeGen ( genConstant , genFunction , genModule ) where #if !MIN_VERSION_base(4,8,0) import Control.Applicative ((<$>)) import Data.Traversable (traverse) #endif import Control.Monad (forM, forM_, when, unless, filterM) import Data.List (nub) import Data.Maybe (fromJust, fromMaybe, catMaybes, mapMaybe) import Data.Monoid ((<>)) 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) 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, genWrappedPtr) import Data.GI.CodeGen.SymbolNaming (upperName, classConstraint, noName, submoduleLocation, lowerName) import Data.GI.CodeGen.Type import Data.GI.CodeGen.Util (tshow) genFunction :: Name -> Function -> CodeGen () genFunction n (Function symbol fnMovedTo callable) = -- Only generate the function if it has not been moved. when (Nothing == fnMovedTo) $ group $ do line $ "-- function " <> symbol handleCGExc (\e -> line ("-- XXX Could not generate function " <> symbol <> "\n-- Error was : " <> describeCGError e)) (do genCCallableWrapper n symbol callable export (NamedSubsection MethodSection $ lowerName n) (lowerName n) ) genBoxedObject :: Name -> Text -> CodeGen () genBoxedObject n typeInit = do let name' = upperName n group $ do line $ "foreign import ccall \"" <> typeInit <> "\" c_" <> typeInit <> " :: " indent $ line "IO GType" group $ do line $ "instance BoxedObject " <> name' <> " where" indent $ line $ "boxedType _ = c_" <> typeInit hsBoot $ line $ "instance BoxedObject " <> name' <> " where" -- | Generate wrapper for structures. genStruct :: Name -> Struct -> CodeGen () genStruct n s = unless (ignoreStruct n s) $ do let name' = upperName n writeHaddock DocBeforeSymbol ("Memory-managed wrapper type.") let decl = line $ "newtype " <> name' <> " = " <> name' <> " (ManagedPtr " <> name' <> ")" hsBoot decl decl addSectionDocumentation ToplevelSection (structDocumentation s) if structIsBoxed s then genBoxedObject n (fromJust $ structTypeInit s) else genWrappedPtr n (structAllocationInfo s) (structSize s) exportDecl (name' <> ("(..)")) -- Generate a builder for a structure filled with zeroes. genZeroStruct n s noName name' -- 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 -> line ("-- XXX Could not generate method " <> name' <> "::" <> name mn <> "\n" <> "-- Error was : " <> describeCGError 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 () genUnion n u = do let name' = upperName n writeHaddock DocBeforeSymbol ("Memory-managed wrapper type.") let decl = line $ "newtype " <> name' <> " = " <> name' <> " (ManagedPtr " <> name' <> ")" hsBoot decl decl addSectionDocumentation ToplevelSection (unionDocumentation u) if unionIsBoxed u then genBoxedObject n (fromJust $ unionTypeInit u) else genWrappedPtr n (unionAllocationInfo u) (unionSize u) exportDecl (name' <> "(..)") -- Generate a builder for a structure filled with zeroes. genZeroUnion n u noName name' -- 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 -> line ("-- XXX Could not generate method " <> name' <> "::" <> name mn <> "\n" <> "-- Error was : " <> describeCGError 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'' = fixInstance (head args') : tail args' 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 non-null -- and "in", even if sometimes the introspection data may say -- otherwise. fixInstance :: Arg -> Arg fixInstance arg = arg { mayBeNull = False , 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''}) -- Type casting with type checking genGObjectCasts :: Name -> Text -> [Name] -> CodeGen () genGObjectCasts n cn_ parents = do let name' = upperName n group $ do line $ "foreign import ccall \"" <> cn_ <> "\"" indent $ line $ "c_" <> cn_ <> " :: IO GType" group $ do bline $ "instance GObject " <> name' <> " where" indent $ group $ do line $ "gobjectType _ = c_" <> cn_ className <- classConstraint n group $ do exportDecl className writeHaddock DocBeforeSymbol (classDoc name') bline $ "class GObject o => " <> className <> " o" line $ "#if MIN_VERSION_base(4,9,0)" line $ "instance {-# OVERLAPPABLE #-} (GObject a, O.UnknownAncestorError " <> name' <> " a) =>" line $ " " <> className <> " a" line $ "#endif" bline $ "instance " <> className <> " " <> name' forM_ parents $ \parent -> do pcls <- classConstraint parent line $ "instance " <> pcls <> " " <> name' -- Safe downcasting. group $ do let safeCast = "to" <> name' exportDecl safeCast writeHaddock DocBeforeSymbol (castDoc name') line $ safeCast <> " :: (MonadIO m, " <> className <> " o) => o -> m " <> name' line $ safeCast <> " = liftIO . unsafeCastTo " <> name' 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 () genObject n o = do let name' = upperName n let t = TInterface n isGO <- isGObject t if not isGO then line $ "-- APIObject \"" <> name' <> "\" does not descend from GObject, it will be ignored." else do writeHaddock DocBeforeSymbol ("Memory-managed wrapper type.") bline $ "newtype " <> name' <> " = " <> name' <> " (ManagedPtr " <> name' <> ")" exportDecl (name' <> "(..)") addSectionDocumentation ToplevelSection (objDocumentation o) -- Type safe casting to parent objects, and implemented interfaces. parents <- instanceTree n genGObjectCasts n (objTypeInit o) (parents <> objInterfaces o) noName name' cppIf CPPOverloading $ fullObjectMethodList n o >>= genMethodList n forM_ (objSignals o) $ \s -> handleCGExc (line . (T.concat ["-- XXX Could not generate signal ", name', "::" , sigName s , "\n", "-- Error was : "] <>) . describeCGError) (genSignal s n) genObjectProperties n o cppIf CPPOverloading $ genNamespacedPropLabels n (objProperties o) (objMethods o) cppIf CPPOverloading $ genObjectSignals n o -- Methods forM_ (objMethods o) $ \f -> do let mn = methodName f handleCGExc (\e -> line ("-- XXX Could not generate method " <> name' <> "::" <> name mn <> "\n" <> "-- Error was : " <> describeCGError e) >> (cppIf CPPOverloading $ genUnsupportedMethodInfo n f)) (genMethod n f) genInterface :: Name -> Interface -> CodeGen () genInterface n iface = do let name' = upperName n line $ "-- interface " <> name' <> " " writeHaddock DocBeforeSymbol ("Memory-managed wrapper type.") deprecatedPragma name' $ ifDeprecated iface bline $ "newtype " <> name' <> " = " <> name' <> " (ManagedPtr " <> name' <> ")" exportDecl (name' <> "(..)") addSectionDocumentation ToplevelSection (ifDocumentation iface) noName name' forM_ (ifSignals iface) $ \s -> handleCGExc (line . (T.concat ["-- XXX Could not generate signal ", name', "::" , sigName s , "\n", "-- Error was : "] <>) . describeCGError) (genSignal s n) cppIf CPPOverloading $ genInterfaceSignals n 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) genGObjectCasts n cn_ uniqueParents 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' <> "`.") bline $ "class ManagedPtrNewtype a => " <> cls <> " a" line $ "instance " <> cls <> " " <> name' genWrappedPtr n (ifAllocationInfo iface) 0 when (not . null . ifProperties $ iface) $ group $ do line $ "-- 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 -> line ("-- XXX Could not generate method " <> name' <> "::" <> name mn <> "\n" <> "-- Error was : " <> describeCGError e) >> (cppIf CPPOverloading $ genUnsupportedMethodInfo n f)) (genMethod n f) -- 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 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 () 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 () genAPIModule n api = submodule (submoduleLocation n api) $ genAPI n api genModule' :: M.Map Name API -> CodeGen () genModule' apis = do mapM_ (uncurry genAPIModule) -- We provide these ourselves $ filter ((`notElem` [ Name "GLib" "Array" , Name "GLib" "Error" , Name "GLib" "HashTable" , Name "GLib" "List" , Name "GLib" "SList" , Name "GLib" "Variant" , Name "GObject" "Value" , Name "GObject" "Closure"]) . fst) $ mapMaybe (traverse dropMovedItems) -- Some callback types are defined inside structs $ map fixAPIStructs -- 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 $ 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 ()) genModule :: M.Map Name API -> CodeGen () 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 = (M.fromList . concatMap extractCallbacksInStruct . M.toList) apis allAPIs <- getAPIs recurseWithAPIs (M.union allAPIs embeddedAPIs) (genModule' (M.union apis embeddedAPIs)) haskell-gi-0.21.5/lib/Data/GI/CodeGen/Config.hs0000644000000000000000000000071100000000000016730 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 { -- | Name of the module being generated. modName :: Text, -- | Whether to print extra info. verbose :: Bool, -- | List of loaded overrides for the code generator. overrides :: Overrides } deriving Show haskell-gi-0.21.5/lib/Data/GI/CodeGen/Constant.hs0000644000000000000000000001101600000000000017314 0ustar0000000000000000module Data.GI.CodeGen.Constant ( genConstant ) where #if !MIN_VERSION_base(4,8,0) import Control.Applicative ((<$>)) #endif import Data.Monoid ((<>)) 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) -- | 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 () writePattern name (SimpleSynonym value t) = line $ "pattern " <> name <> " = " <> value <> " :: " <> t writePattern name (ExplicitSynonym view expression value t) = do -- Supported only on ghc >= 7.10 setModuleMinBase Base48 line $ "pattern " <> name <> " <- (" <> view <> " -> " <> value <> ") :: " <> t <> " where" indent $ line $ name <> " = " <> expression <> " " <> value <> " :: " <> t genConstant :: Name -> Constant -> CodeGen () genConstant (Name _ name) c = group $ do setLanguagePragmas ["PatternSynonyms", "ScopedTypeVariables", "ViewPatterns"] deprecatedPragma name (constantDeprecated c) handleCGExc (\e -> line $ "-- XXX: Could not generate constant: " <> describeCGError e) (do writeDocumentation DocBeforeSymbol (constantDocumentation c) assignValue name (constantType c) (constantValue c) export ToplevelSection ("pattern " <> 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 "False" showBasicType TBoolean "false" = return "False" showBasicType TBoolean "1" = return "True" showBasicType TBoolean "true" = return "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 -- We take care of this one separately above showBasicType TPtr _ = notImplementedError $ "Cannot directly show a pointer" haskell-gi-0.21.5/lib/Data/GI/CodeGen/Conversions.hs0000644000000000000000000011500600000000000020037 0ustar0000000000000000{-# LANGUAGE PatternGuards, DeriveFunctor #-} module Data.GI.CodeGen.Conversions ( convert , genConversion , unpackCArray , computeArrayLength , callableHasClosures , hToF , fToH , transientToH , haskellType , isoHaskellType , foreignType , argumentType , elementType , elementMap , elementTypeAndMap , isManaged , typeIsNullable , typeIsPtr , typeIsCallback , maybeNullConvert , nullPtrForType , typeAllocInfo , TypeAllocInfo(..) , apply , mapC , literal , Constructor(..) ) where #if !MIN_VERSION_base(4,8,0) import Control.Applicative ((<$>), (<*>), pure, Applicative) #endif import Control.Monad (when) import Data.Maybe (isJust) import Data.Monoid ((<>)) 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 return = Pure (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 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" TBasicType _ -> return "length" TInterface _ -> return "length" TCArray{} -> return "length" _ -> notImplementedError $ "Don't know how to compute length of " <> tshow t computeArrayLength _ t = notImplementedError $ "computeArrayLength called on non-CArray type " <> tshow t convert :: Text -> BaseCodeGen e Converter -> BaseCodeGen 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 badIntroError "Transferring a non-GObject object" -- castPtr since we accept any instance of the class associated with -- the GObject, not just the precise type of the GObject, while the -- foreign function declaration requires a pointer of the precise -- type. else return $ M "unsafeManagedPtrCastPtr" hVariantToF :: Transfer -> CodeGen Constructor hVariantToF transfer = if transfer == TransferEverything then return $ M "B.GVariant.disownGVariant" else return $ M "unsafeManagedPtrGetPtr" hParamSpecToF :: Transfer -> CodeGen Constructor hParamSpecToF transfer = if transfer == TransferEverything then return $ M "B.GParamSpec.disownGParamSpec" else return $ M "unsafeManagedPtrGetPtr" hBoxedToF :: Transfer -> CodeGen 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 | TParamSpec <- t = hParamSpecToF transfer | Just (APIEnum _) <- a = return "(fromIntegral . fromEnum)" | Just (APIFlags _) <- a = return "gflagsToWord" | Just (APIObject _) <- a = hObjectToF t transfer | Just (APIInterface _) <- a = hObjectToF t transfer | Just (APIStruct s) <- a = hStructToF s transfer | Just (APIUnion u) <- a = hUnionToF u transfer -- Converting callback types requires more context, we leave that -- as a special case to be implemented by the caller. | Just (APICallback _) <- a = error "Cannot handle callback type here!! " | TByteArray <- t = return $ M "packGByteArray" | TCArray True _ _ (TBasicType TUTF8) <- t = return $ M "packZeroTerminatedUTF8CArray" | TCArray True _ _ (TBasicType TFileName) <- t = return $ M "packZeroTerminatedFileNameArray" | TCArray True _ _ (TBasicType 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 (fromIntegral . fromEnum))" | TCArray False _ _ (TBasicType TGType) <- t = return $ M "(packMapStorableArray gtypeToCGType)" | TCArray False _ _ (TBasicType TFloat) <- t = return $ M "(packMapStorableArray realToFrac)" | TCArray False _ _ (TBasicType TDouble) <- t = return $ M "(packMapStorableArray realToFrac)" | TCArray False _ _ (TBasicType _) <- t = return $ M "packStorableArray" | TCArray{} <- t = notImplementedError $ "Don't know how to pack C array of type " <> tshow t | otherwise = case (typeShow hType, typeShow fType) of ("T.Text", "CString") -> return $ M "textToCString" ("[Char]", "CString") -> return $ M "stringToCString" ("Char", "CInt") -> return "(fromIntegral . ord)" ("Bool", "CInt") -> return "(fromIntegral . fromEnum)" ("Float", "CFloat") -> return "realToFrac" ("Double", "CDouble") -> return "realToFrac" ("GType", "CGType") -> return "gtypeToCGType" _ -> notImplementedError $ "Don't know how to convert " <> 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", "ptrPackPtr", "ptrUnpackPtr") hashTablePtrPackers (TBasicType TUTF8) = return ("(Just ptr_to_g_free)", "cstringPackPtr", "cstringUnpackPtr") 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 Constructor boxedForeignPtr constructor transfer = return $ case transfer of TransferEverything -> M $ parenthesize $ "wrapBoxed " <> constructor _ -> M $ parenthesize $ "newBoxed " <> constructor suForeignPtr :: Bool -> TypeRep -> Transfer -> CodeGen 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 Constructor structForeignPtr s = suForeignPtr (structIsBoxed s) unionForeignPtr :: Union -> TypeRep -> Transfer -> CodeGen 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 Constructor fVariantToH transfer = return $ M $ case transfer of TransferEverything -> "B.GVariant.wrapGVariantPtr" _ -> "B.GVariant.newGVariantFromPtr" fParamSpecToH :: Transfer -> CodeGen Constructor fParamSpecToH transfer = return $ M $ case transfer of TransferEverything -> "B.GParamSpec.wrapGParamSpecPtr" _ -> "B.GParamSpec.newGParamSpecFromPtr" fToH' :: Type -> Maybe API -> TypeRep -> TypeRep -> Transfer -> ExcCodeGen Constructor fToH' t a hType fType transfer | ( hType == fType ) = return Id | Just (APIEnum _) <- a = return "(toEnum . fromIntegral)" | Just (APIFlags _) <- a = return "wordToGFlags" | TError <- t = boxedForeignPtr "GError" transfer | TVariant <- t = fVariantToH transfer | TParamSpec <- t = fParamSpecToH transfer | Just (APIStruct s) <- a = structForeignPtr s hType transfer | Just (APIUnion u) <- a = unionForeignPtr u hType transfer | Just (APIObject _) <- a = fObjectToH t hType transfer | Just (APIInterface _) <- a = fObjectToH t hType transfer | Just (APICallback _) <- 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 t else fToH t TransferNothing Just (APIUnion u) -> if unionIsBoxed u then wrapTransient t else fToH t TransferNothing _ -> fToH t TransferNothing transientToH t transfer = fToH t transfer -- | Wrap the given transient. wrapTransient :: Type -> CodeGen Converter wrapTransient t = do hCon <- typeConName <$> haskellType t return $ lambdaConvert $ "B.ManagedPtr.withTransient " <> hCon 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 _ -> return $ apply $ M $ parenthesize $ "unpackStorableArrayWithLength " <> length TInterface _ -> do a <- findAPI t isScalar <- typeIsEnumOrFlag t hType <- haskellType t fType <- foreignType t innerConstructor <- fToH' t a hType fType transfer let (boxed, size) = case a of Just (APIStruct s) -> (structIsBoxed s, structSize s) Just (APIUnion u) -> (unionIsBoxed u, unionSize u) _ -> (False, 0) let unpacker | isScalar = "unpackStorableArrayWithLength" | (size == 0) = "unpackPtrArrayWithLength" | boxed = "unpackBoxedArrayWithLength " <> tshow size | otherwise = "unpackBlockArrayWithLength " <> tshow size 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." -- | Given a type find the typeclasses the type belongs to, and return -- the representation of the type in the function signature and the -- list of typeclass constraints for the type. argumentType :: [Char] -> Type -> CodeGen ([Char], Text, [Text]) argumentType [] _ = error "out of letters" argumentType letters (TGList a) = do (ls, name, constraints) <- argumentType letters a return (ls, "[" <> name <> "]", constraints) argumentType letters (TGSList a) = do (ls, name, constraints) <- argumentType letters a return (ls, "[" <> name <> "]", constraints) argumentType letters@(l:ls) t = do api <- findAPI t s <- 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 return (ls, T.singleton l, [cls <> " " <> T.singleton l]) Just (APIObject _) -> do isGO <- isGObject t if isGO then do cls <- typeConstraint t return (ls, T.singleton l, [cls <> " " <> T.singleton l]) else return (letters, s, []) Just (APICallback cb) -> -- See [Note: Callables that throw] if callableThrows (cbCallable cb) then do ft <- typeShow <$> foreignType t return (letters, ft, []) else return (letters, s, []) _ -> return (letters, 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 "CLong" haskellBasicType TULong = con0 "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" -- | This translates GI types to the types used for generated Haskell code. haskellType :: Type -> CodeGen 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 (TInterface (Name "GObject" "Closure")) = return $ "Closure" `con` [] haskellType (TInterface (Name "GObject" "Value")) = return $ "GValue" `con` [] haskellType t@(TInterface n) = do api <- getAPI t tname <- qualifiedAPI 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 = any (/= -1) . map argClosure . args -- | Check whether the given type corresponds to a callback. typeIsCallback :: Type -> CodeGen 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. isoHaskellType :: Type -> CodeGen TypeRep isoHaskellType t@(TInterface n) = do api <- findAPI t case api of Just (APICallback cb) -> do tname <- qualifiedAPI 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 TypeRep foreignType (TBasicType t) = return $ foreignBasicType t foreignType (TCArray zt _ _ t) = do api <- findAPI t let size = case api of Just (APIStruct s) -> structSize s Just (APIUnion u) -> unionSize u _ -> 0 if size == 0 || zt then ptr <$> foreignType t else foreignType t foreignType (TGArray a) = do inner <- foreignType a return $ ptr ("GArray" `con` [inner]) foreignType (TPtrArray a) = do inner <- foreignType a return $ ptr ("GPtrArray" `con` [inner]) foreignType (TByteArray) = return $ ptr ("GByteArray" `con` []) foreignType (TGList a) = do inner <- foreignType a return $ ptr ("GList" `con` [inner]) foreignType (TGSList a) = do inner <- foreignType a return $ ptr ("GSList" `con` [inner]) foreignType (TGHash a b) = do innerA <- foreignType a innerB <- foreignType b return $ ptr ("GHashTable" `con` [innerA, innerB]) foreignType t@TError = ptr <$> haskellType t foreignType t@TVariant = ptr <$> haskellType t foreignType t@TParamSpec = ptr <$> haskellType t foreignType (TInterface (Name "GObject" "Closure")) = return $ ptr $ "Closure" `con` [] foreignType (TInterface (Name "GObject" "Value")) = return $ ptr $ "GValue" `con` [] 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 tname <- qualifiedSymbol (callbackCType $ name n) n return (funptr $ tname `con` []) _ -> do tname <- qualifiedAPI n return (ptr $ tname `con` []) -- | Whether the give type corresponds to an enum or flag. typeIsEnumOrFlag :: Type -> CodeGen 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. data TypeAllocInfo = TypeAllocInfo { typeAllocInfoIsBoxed :: Bool , typeAllocInfoSize :: Int -- ^ In bytes. } -- | Information on how to allocate the given type, if known. typeAllocInfo :: Type -> CodeGen (Maybe TypeAllocInfo) typeAllocInfo t = do api <- findAPI t case api of Just (APIStruct s) -> case structSize s of 0 -> return Nothing n -> let info = TypeAllocInfo { typeAllocInfoIsBoxed = structIsBoxed s , typeAllocInfoSize = n } in return (Just info) _ -> return Nothing -- | Returns whether the given type corresponds to a `ManagedPtr` -- instance (a thin wrapper over a `ForeignPtr`). isManaged :: Type -> CodeGen Bool isManaged TError = return True isManaged TVariant = return True isManaged TParamSpec = 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 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 (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 (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 (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 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 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.21.5/lib/Data/GI/CodeGen/CtoHaskellMap.hs0000644000000000000000000001330600000000000020216 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 import Data.Monoid ((<>)) import Data.Text (Text) import qualified Data.Text as T import Data.String (IsString(..)) import Data.GI.CodeGen.GtkDoc (CRef(..)) import Data.GI.CodeGen.API (API(..), Name(..), Callback(..), Constant(..), Flags(..), Enumeration(..), EnumerationMember(..), Interface(..), Object(..), Function(..), Method(..), Struct(..), Union(..)) import Data.GI.CodeGen.ModulePath (ModulePath, dotModulePath, (/.)) import Data.GI.CodeGen.SymbolNaming (submoduleLocation, lowerName, upperName) import Data.GI.CodeGen.Util (ucFirst) -- | Link to an identifier, module, etc. data Hyperlink = IdentifierLink Text | ModuleLink Text | ModuleLinkWithAnchor Text Text deriving (Show, Eq) -- Just for convenience instance IsString Hyperlink where fromString = IdentifierLink . T.pack -- | 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 = [(TypeRef "gboolean", "Bool"), (ConstantRef "TRUE", "True"), (ConstantRef "FALSE", "False"), (TypeRef "GError", "GError"), (TypeRef "GType", "GType"), (TypeRef "GVariant", "GVariant"), (ConstantRef "NULL", "Nothing")] -- | Obtain the absolute location of the module where the given `API` -- lives. location :: Name -> API -> ModulePath location n api = ("GI" /. ucFirst (namespace n)) <> submoduleLocation n api -- | Obtain the fully qualified symbol. fullyQualified :: Name -> API -> Text -> Hyperlink fullyQualified n api symbol = IdentifierLink $ dotModulePath (location 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), fullyQualified n (APIConst c) $ name n), (TypeRef (constantCType c), fullyQualified n (APIConst c) $ name n)] -- | Extract the C name of a function. funcRefs :: Name -> Function -> [(CRef, Hyperlink)] funcRefs n f = [(FunctionRef (fnSymbol f), fullyQualified 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 = (TypeRef (enumCType e), fullyQualified n api $ upperName n) : map memberToRef (enumMembers e) where memberToRef :: EnumerationMember -> (CRef, Hyperlink) memberToRef em = (ConstantRef (enumMemberCId em), fullyQualified n api $ upperName $ n {name = name n <> "_" <> enumMemberName em}) -- | 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) = [(TypeRef ctype, fullyQualified n api (upperName n))] -- | Refs to the methods for a given owner. methodRefs :: Name -> API -> [Method] -> [(CRef, Hyperlink)] methodRefs n api methods = map methodRef methods where methodRef :: Method -> (CRef, Hyperlink) methodRef m@(Method {methodName = mn}) = -- Method name namespaced by the owner. let mn' = mn {name = name n <> "_" <> name mn} in (FunctionRef (methodSymbol m), fullyQualified n api $ lowerName mn') -- | 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) -- | 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) haskell-gi-0.21.5/lib/Data/GI/CodeGen/CtoHaskellMap.hs-boot0000644000000000000000000000041200000000000021151 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.21.5/lib/Data/GI/CodeGen/EnumFlags.hs0000644000000000000000000001345500000000000017415 0ustar0000000000000000-- | Support for enums and flags. module Data.GI.CodeGen.EnumFlags ( genEnum , genFlags ) where import Control.Monad (when, forM_) import Data.Monoid ((<>)) import Data.Text (Text) 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) 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_ 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 () genBoxedEnum n typeInit = do let name' = upperName n group $ do line $ "foreign import ccall \"" <> typeInit <> "\" c_" <> typeInit <> " :: " indent $ line "IO GType" group $ do bline $ "instance BoxedEnum " <> name' <> " where" indent $ line $ "boxedEnumType _ = c_" <> typeInit genEnum :: Name -> Enumeration -> CodeGen () genEnum n@(Name _ name) enum = do line $ "-- Enum " <> name let docSection = NamedSubsection EnumSection (upperName n) handleCGExc (\e -> line $ "-- XXX Could not generate: " <> describeCGError e) (do genEnumOrFlags docSection n enum case enumTypeInit enum of Nothing -> return () Just ti -> genBoxedEnum n ti) genBoxedFlags :: Name -> Text -> CodeGen () genBoxedFlags n typeInit = do let name' = upperName n group $ do line $ "foreign import ccall \"" <> typeInit <> "\" c_" <> typeInit <> " :: " indent $ line "IO GType" group $ do bline $ "instance BoxedFlags " <> name' <> " where" indent $ line $ "boxedFlagsType _ = c_" <> typeInit -- | Very similar to enums, but we also declare ourselves as members of -- the IsGFlag typeclass. genFlags :: Name -> Flags -> CodeGen () genFlags n@(Name _ name) (Flags enum) = do line $ "-- Flags " <> name let docSection = NamedSubsection FlagSection (upperName n) handleCGExc (\e -> line $ "-- XXX Could not generate: " <> describeCGError 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 () 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.21.5/lib/Data/GI/CodeGen/Fixups.hs0000644000000000000000000001324700000000000017011 0ustar0000000000000000-- | Various fixups in the introspection data. module Data.GI.CodeGen.Fixups ( dropMovedItems , guessPropertyNullability , detectGObject ) where import Data.Maybe (isNothing, isJust) import Data.Monoid ((<>)) import qualified Data.Text as T 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 haskell-gi-0.21.5/lib/Data/GI/CodeGen/GObject.hs0000644000000000000000000000260300000000000017042 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 Bool typeDoParentSearch parent (TInterface n) = findAPIByName n >>= apiDoParentSearch parent n typeDoParentSearch _ _ = return False apiDoParentSearch :: Name -> Name -> API -> CodeGen Bool apiDoParentSearch parent n api | parent == n = return True | otherwise = case api of APIObject o -> case objParent o of Just 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 isGObject :: Type -> CodeGen Bool isGObject = typeDoParentSearch $ Name "GObject" "Object" -- | Check whether the given name descends from GObject. nameIsGObject :: Name -> CodeGen Bool nameIsGObject n = findAPIByName n >>= apiIsGObject n apiIsGObject :: Name -> API -> CodeGen Bool apiIsGObject = apiDoParentSearch $ Name "GObject" "Object" haskell-gi-0.21.5/lib/Data/GI/CodeGen/GType.hsc0000644000000000000000000000120100000000000016711 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.21.5/lib/Data/GI/CodeGen/GtkDoc.hs0000644000000000000000000003616700000000000016714 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(..) ) where import Prelude hiding (takeWhile) #if !MIN_VERSION_base(4,8,0) import Control.Applicative ((<$>), (<*)) #endif import Data.Monoid ((<>)) import Control.Applicative ((<|>)) import Data.Attoparsec.Text import Data.Char (isAsciiUpper, isAsciiLower, isDigit) import qualified Data.Text as T import Data.Text (Text) -- | A parsed gtk-doc token. data Token = Literal 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 Text | ParamRef Text | ConstantRef Text | SignalRef Text Text | PropertyRef Text Text | VMethodRef Text Text | StructFieldRef Text Text | TypeRef Text deriving (Show, Eq, Ord) -- | A parsed representation of gtk-doc formatted documentation. newtype GtkDoc = GtkDoc [Token] deriving (Show, Eq) -- | Parse the given gtk-doc formatted documentation. -- -- === __Examples__ -- >>> parseGtkDoc "" -- GtkDoc [] -- -- >>> parseGtkDoc "func()" -- GtkDoc [SymbolRef (FunctionRef "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 (FunctionRef "foo"),Literal " for free cookies"] -- -- >>> parseGtkDoc "The signal ##%#GtkButton::activate is related to gtk_button_activate()." -- GtkDoc [Literal "The signal ##%",SymbolRef (SignalRef "GtkButton" "activate"),Literal " is related to ",SymbolRef (FunctionRef "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 (FunctionRef "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 <|> parseSignal <|> parseProperty <|> parseVMethod <|> parseStructField <|> parseType <|> parseConstant <|> parseParam <|> parseEscaped <|> parseVerbatim <|> parseCodeBlock <|> parseUrl <|> parseImage <|> parseSectionHeader <|> parseList <|> parseBoringLiteral -- | Parse a signal name, of the form -- > #Object::signal -- -- === __Examples__ -- >>> parseOnly (parseSignal <* endOfInput) "#GtkButton::activate" -- Right (SymbolRef (SignalRef "GtkButton" "activate")) parseSignal :: Parser Token parseSignal = do _ <- char '#' obj <- parseCIdent _ <- string "::" signal <- signalOrPropName return (SymbolRef (SignalRef obj signal)) -- | Parse a property name, of the form -- > #Object:property -- -- === __Examples__ -- >>> parseOnly (parseProperty <* endOfInput) "#GtkButton:always-show-image" -- Right (SymbolRef (PropertyRef "GtkButton" "always-show-image")) parseProperty :: Parser Token parseProperty = do _ <- char '#' obj <- parseCIdent _ <- char ':' property <- signalOrPropName return (SymbolRef (PropertyRef obj property)) -- | Parse a reference to a virtual method, of the form -- > #Struct.method() -- -- === __Examples__ -- >>> parseOnly (parseVMethod <* endOfInput) "#Foo.bar()" -- Right (SymbolRef (VMethodRef "Foo" "bar")) parseVMethod :: Parser Token parseVMethod = do _ <- char '#' obj <- parseCIdent _ <- char '.' method <- parseCIdent _ <- string "()" return (SymbolRef (VMethodRef obj method)) -- | 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 (parseType <* endOfInput) "#Foo" -- Right (SymbolRef (TypeRef "Foo")) parseType :: Parser Token parseType = do _ <- char '#' obj <- parseCIdent return (SymbolRef (TypeRef 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)) -- | Whether the given character is valid in a C identifier. isCIdent :: Char -> Bool isCIdent '_' = True isCIdent c = isDigit c || isAsciiUpper c || isAsciiLower c -- | 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 -- | 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, 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 (FunctionRef "test_func")) -- -- >>> parseOnly (parseFunctionRef <* endOfInput) "not_a_func" -- Right (Literal "not_a_func") parseFunctionRef :: Parser Token parseFunctionRef = do ident <- parseCIdent option (Literal ident) (string "()" >> return (SymbolRef (FunctionRef ident))) -- | 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 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 = 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') haskell-gi-0.21.5/lib/Data/GI/CodeGen/Haddock.hs0000644000000000000000000002616500000000000017073 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,8,0) import Control.Applicative ((<$>)) #endif import Control.Monad (mapM_, unless) import qualified Data.Map as M import Data.Monoid ((<>)) import qualified Data.Text as T import Data.Text (Text) import Data.GI.GIR.Arg (Arg(..)) 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) import Data.GI.CodeGen.Overrides (onlineDocsMap) import Data.GI.CodeGen.SymbolNaming (lowerSymbol) -- | 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 "" (GtkDoc [Literal "Hello ", Literal "World!"]) -- "Hello World!" -- -- >>> let c2h = M.fromList [(FunctionRef "foo", "foo()")] -- >>> formatHaddock c2h "" (GtkDoc [SymbolRef (FunctionRef "foo")]) -- "'foo()'" -- -- >>> let onlineDocs = "http://wiki.haskell.org" -- >>> formatHaddock M.empty onlineDocs (GtkDoc [ExternalLink (Link "GI" "GObjectIntrospection")]) -- "" -- -- >>> formatHaddock M.empty "a" (GtkDoc [List [ListItem (GtkDoc [Image (Link "test" "test.png")]) []]]) -- "\n* <>\n" formatHaddock :: M.Map CRef Hyperlink -> Text -> GtkDoc -> Text formatHaddock c2h docBase (GtkDoc doc) = T.concat $ map formatToken doc where formatToken :: Token -> Text formatToken (Literal l) = escape l 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 l h formatToken (List l) = formatList c2h docBase l formatToken (SymbolRef (ParamRef p)) = "/@" <> lowerSymbol p <> "@/" formatToken (SymbolRef cr) = case M.lookup cr c2h of Just hr -> formatHyperlink hr Nothing -> formatUnknownCRef c2h cr -- | Format a `CRef` whose Haskell representation is not known. formatUnknownCRef :: M.Map CRef Hyperlink -> CRef -> Text formatUnknownCRef _ (FunctionRef f) = formatCRef $ f <> "()" formatUnknownCRef _ (ParamRef _) = error $ "Should not be reached" formatUnknownCRef c2h (SignalRef owner signal) = case M.lookup (TypeRef owner) c2h of Nothing -> formatCRef $ owner <> "::" <> signal Just r -> formatHyperlink r <> "::" <> formatCRef signal formatUnknownCRef c2h (PropertyRef owner prop) = case M.lookup (TypeRef owner) c2h of Nothing -> formatCRef $ owner <> ":" <> prop Just r -> formatHyperlink r <> ":" <> formatCRef prop formatUnknownCRef c2h (VMethodRef owner vmethod) = case M.lookup (TypeRef owner) c2h of Nothing -> formatCRef $ owner <> "." <> vmethod <> "()" Just r -> formatHyperlink r <> "." <> formatCRef vmethod <> "()" formatUnknownCRef c2h (StructFieldRef owner field) = case M.lookup (TypeRef owner) c2h of Nothing -> formatCRef $ owner <> "." <> field Just r -> formatHyperlink r <> "." <> formatCRef field formatUnknownCRef _ (TypeRef t) = formatCRef t formatUnknownCRef _ (ConstantRef t) = formatCRef t -- | Formatting for an unknown C reference. formatCRef :: Text -> Text formatCRef t = "@/" <> escape t <> "/@" -- | Format a `Hyperlink` into plain `Text`. formatHyperlink :: Hyperlink -> Text formatHyperlink (IdentifierLink t) = "'" <> t <> "'" formatHyperlink (ModuleLink m) = "\"" <> m <> "\"" formatHyperlink (ModuleLinkWithAnchor m a) = "\"" <> 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 -> Int -> GtkDoc -> Text formatSectionHeader c2h docBase level header = T.replicate level "=" <> " " <> formatHaddock c2h docBase header <> "\n" -- | Format a list of items. formatList :: M.Map CRef Hyperlink -> Text -> [ListItem] -> Text formatList c2h docBase 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 = formatHaddock c2h docBase -- | 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 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 () deprecatedPragma _ Nothing = return () deprecatedPragma name (Just info) = do c2h <- getC2HMap docBase <- getDocBase line $ "{-# DEPRECATED " <> name <> " " <> (T.pack . show) (note <> reason c2h docBase) <> " #-}" where reason c2h docBase = case deprecationMessage info of Nothing -> [] Just msg -> map (formatHaddock c2h docBase . 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 -> Documentation -> Text formatDocumentation c2h docBase doc = do let description = case rawDocText doc of Just raw -> formatHaddock c2h docBase (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 () writeDocumentation pos doc = do line $ case pos of DocBeforeSymbol -> "{- |" DocAfterSymbol -> "{- ^" c2h <- getC2HMap docBase <- getDocBase let haddock = formatDocumentation c2h docBase doc mapM_ line (T.lines haddock) line "-}" -- | Like `writeDocumentation`, but allows us to pass explicitly the -- Haddock comment to write. writeHaddock :: RelativeDocPosition -> Text -> CodeGen () writeHaddock pos haddock = let marker = case pos of DocBeforeSymbol -> "|" DocAfterSymbol -> "^" in if T.any (== '\n') haddock then do line $ "{- " <> marker mapM_ line (T.lines haddock) line $ "-}" else line $ "-- " <> marker <> " " <> haddock -- | Write the documentation for the given argument. writeArgDocumentation :: Arg -> CodeGen () writeArgDocumentation arg = case rawDocText (argDoc arg) of Nothing -> return () Just raw -> do c2h <- getC2HMap docBase <- getDocBase line $ "{- ^ /@" <> lowerSymbol (argCName arg) <> "@/: " <> formatHaddock c2h docBase (parseGtkDoc raw) <> " -}" -- | Write the documentation for the given return value. writeReturnDocumentation :: Callable -> Bool -> CodeGen () writeReturnDocumentation callable skip = do c2h <- getC2HMap docBase <- getDocBase let returnValInfo = if skip then [] else case rawDocText (returnDocumentation callable) of Nothing -> [] Just raw -> ["__Returns:__ " <> formatHaddock c2h docBase (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) $ line $ "{- ^ " <> fullInfo <> " -}" -- | Add the given text to the documentation for the section being generated. addSectionDocumentation :: HaddockSection -> Documentation -> CodeGen () addSectionDocumentation section doc = do c2h <- getC2HMap docBase <- getDocBase let formatted = formatDocumentation c2h docBase doc addSectionFormattedDocs section formatted haskell-gi-0.21.5/lib/Data/GI/CodeGen/Inheritance.hs0000644000000000000000000001511000000000000017753 0ustar0000000000000000{-# LANGUAGE ScopedTypeVariables #-} module Data.GI.CodeGen.Inheritance ( fullObjectPropertyList , fullInterfacePropertyList , fullObjectSignalList , fullInterfaceSignalList , fullObjectMethodList , fullInterfaceMethodList , instanceTree ) where #if !MIN_VERSION_base(4,8,0) import Control.Applicative ((<$>), (<*>)) #endif import Control.Monad (foldM, when) import qualified Data.Map as M import Data.Monoid ((<>)) import Data.Text (Text) import Data.GI.CodeGen.API import Data.GI.CodeGen.Code (findAPIByName, CodeGen, line) import Data.GI.CodeGen.Util (tshow) -- | Find the parent of a given object when building the -- instanceTree. For the purposes of the binding we do not need to -- distinguish between GObject.Object and GObject.InitiallyUnowned. getParent :: API -> Maybe Name getParent (APIObject o) = rename $ objParent o where rename :: Maybe Name -> Maybe Name rename (Just (Name "GObject" "InitiallyUnowned")) = Just (Name "GObject" "Object") rename x = x getParent _ = Nothing -- | Compute the (ordered) list of parents of the current object. instanceTree :: Name -> CodeGen [Name] instanceTree n = do api <- findAPIByName n case getParent api of Just p -> (p :) <$> instanceTree p Nothing -> return [] -- A class for qualities of an object/interface that it inherits from -- its ancestors. Properties and Signals are two classes of interest. class Inheritable i where ifInheritables :: Interface -> [i] objInheritables :: Object -> [i] iName :: i -> Text instance Inheritable Property where ifInheritables = ifProperties objInheritables = objProperties iName = propName instance Inheritable Signal where ifInheritables = ifSignals objInheritables = objSignals iName = sigName 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 [(Name, i)] apiInheritables n = do api <- findAPIByName n case api of APIInterface iface -> return $ map ((,) n) (ifInheritables iface) APIObject object -> return $ map ((,) n) (objInheritables object) _ -> error $ "apiInheritables : Unexpected API : " ++ show n fullAPIInheritableList :: Inheritable i => Name -> CodeGen [(Name, i)] fullAPIInheritableList n = do api <- findAPIByName n case api of APIInterface iface -> fullInterfaceInheritableList n iface APIObject object -> fullObjectInheritableList n object _ -> error $ "FullAPIInheritableList : Unexpected API : " ++ show n fullObjectInheritableList :: Inheritable i => Name -> Object -> CodeGen [(Name, i)] fullObjectInheritableList n obj = do iT <- instanceTree n (++) <$> (concat <$> mapM apiInheritables (n : iT)) <*> (concat <$> mapM apiInheritables (objInterfaces obj)) fullInterfaceInheritableList :: Inheritable i => Name -> Interface -> CodeGen [(Name, i)] fullInterfaceInheritableList n iface = (++) (map ((,) n) (ifInheritables iface)) <$> (concat <$> mapM fullAPIInheritableList (ifPrerequisites iface)) -- | It is sometimes the case that a property name or signal is defined -- both in an object and in one of its ancestors/implemented -- interfaces. This is harmless if the properties are isomorphic -- (there will be more than one qualified set of property -- setters/getters that we can call, but they are all isomorphic). If -- they are not isomorphic we print a warning, and choose to use the -- one closest to the leaves of the object hierarchy. removeDuplicates :: forall i. (Eq i, Show i, Inheritable i) => Bool -> [(Name, i)] -> CodeGen [(Name, i)] removeDuplicates verbose inheritables = (filterTainted . M.toList) <$> foldM filterDups M.empty inheritables where filterDups :: M.Map Text (Bool, Name, i) -> (Name, i) -> CodeGen (M.Map Text (Bool, Name, i)) filterDups m (name, prop) = case M.lookup (iName prop) m of Just (tainted, n, p) | tainted -> return m | (p == prop) -> return m -- Duplicated, but isomorphic property | otherwise -> do 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 [(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 [(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 [(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 [(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 [(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 [(Name, Method)] fullInterfaceMethodList n i = fullInterfaceInheritableList n i >>= removeDuplicates False haskell-gi-0.21.5/lib/Data/GI/CodeGen/LibGIRepository.hs0000644000000000000000000001620600000000000020557 0ustar0000000000000000{-# LANGUAGE ScopedTypeVariables #-} -- | A minimal wrapper for libgirepository. module Data.GI.CodeGen.LibGIRepository ( girRequire , setupTypelibSearchPath , FieldInfo(..) , girStructFieldInfo , girUnionFieldInfo , girLoadGType ) where #if !MIN_VERSION_base(4,8,0) import Control.Applicative ((<$>)) #endif import Control.Monad (forM, when, (>=>)) import qualified Data.Map as M import Data.Text (Text) import qualified Data.Text as T import Foreign.C.Types (CInt(..), CSize(..)) import Foreign.C.String (CString, 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 (BoxedObject(..), GType(..), CGType, ManagedPtr) import Data.GI.Base.GError (GError, checkGError) import Data.GI.Base.ManagedPtr (wrapBoxed, withManagedPtr) import Data.GI.Base.Utils (allocMem, freeMem) import Data.GI.CodeGen.Util (splitOn) -- | Wrapper for 'GIBaseInfo' newtype BaseInfo = BaseInfo (ManagedPtr BaseInfo) -- | Wrapper for 'GITypelib' newtype Typelib = Typelib (Ptr Typelib) -- | 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 } foreign import ccall "g_base_info_gtype_get_type" c_g_base_info_gtype_get_type :: IO GType instance BoxedObject BaseInfo where boxedType _ = c_g_base_info_gtype_get_type foreign import ccall "g_irepository_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) (error $ "Could not load typelib for " ++ show ns ++ " version " ++ show version) return (Typelib typelib) foreign import ccall "g_irepository_find_by_name" g_irepository_find_by_name :: Ptr () -> CString -> CString -> IO (Ptr BaseInfo) -- | Find a given baseinfo by name, or give an error if it cannot be -- found. girFindByName :: Text -> Text -> IO BaseInfo girFindByName ns name = withTextCString ns $ \cns -> withTextCString name $ \cname -> do ptr <- g_irepository_find_by_name nullPtr cns cname if ptr == nullPtr then error ("Could not find " ++ T.unpack ns ++ "::" ++ T.unpack name) else wrapBoxed BaseInfo ptr foreign import ccall "g_field_info_get_offset" g_field_info_get_offset :: Ptr BaseInfo -> IO CInt foreign import ccall "g_base_info_get_name" g_base_info_get_name :: Ptr BaseInfo -> IO CString -- | 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 -- | Load a symbol from the dynamic library associated to the given namespace. girSymbol :: forall a. Text -> Text -> IO (FunPtr a) girSymbol ns symbol = do typelib <- withTextCString ns $ \cns -> checkGError (g_irepository_require nullPtr cns nullPtr 0) (error $ "Could not load typelib " ++ show ns) funPtrPtr <- allocMem :: IO (Ptr (FunPtr a)) result <- withTextCString symbol $ \csymbol -> g_typelib_symbol typelib csymbol funPtrPtr when (result /= 1) $ error ("Could not resolve symbol " ++ show symbol ++ " in namespace " ++ show ns) funPtr <- peek funPtrPtr freeMem funPtrPtr return funPtr type GTypeInit = IO CGType foreign import ccall "dynamic" gtypeInit :: FunPtr GTypeInit -> GTypeInit -- | Load a GType given the namespace where it lives and the type init -- function. girLoadGType :: Text -> Text -> IO GType girLoadGType ns typeInit = do funPtr <- girSymbol ns typeInit GType <$> gtypeInit funPtr haskell-gi-0.21.5/lib/Data/GI/CodeGen/ModulePath.hs0000644000000000000000000000324100000000000017566 0ustar0000000000000000{-# LANGUAGE GeneralizedNewtypeDeriving #-} -- | Abstract representation for paths into modules. module Data.GI.CodeGen.ModulePath ( ModulePath(..) , toModulePath , (/.) , dotModulePath ) where import Data.Monoid (Monoid(..), (<>)) 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.21.5/lib/Data/GI/CodeGen/OverloadedLabels.hs0000644000000000000000000000665300000000000020745 0ustar0000000000000000module Data.GI.CodeGen.OverloadedLabels ( genOverloadedLabels ) where #if !MIN_VERSION_base(4,8,0) import Control.Applicative ((<$>)) #endif import Data.Maybe (isNothing) import Data.Monoid ((<>)) import Control.Monad (forM_) import qualified Data.Set as S import Data.Text (Text) import qualified Data.Text as T import Data.GI.CodeGen.API import Data.GI.CodeGen.Code import Data.GI.CodeGen.SymbolNaming import Data.GI.CodeGen.Util (lcFirst) -- | A list of all overloadable identifiers in the set of APIs (current -- properties and methods). findOverloaded :: [(Name, API)] -> CodeGen [Text] findOverloaded apis = S.toList <$> go apis S.empty where go :: [(Name, API)] -> S.Set Text -> CodeGen (S.Set Text) go [] set = return set go ((_, api):apis) set = case api of APIInterface iface -> go apis (scanInterface iface set) APIObject object -> go apis (scanObject object set) APIStruct s -> go apis (scanStruct s set) APIUnion u -> go apis (scanUnion u set) _ -> go apis set scanObject :: Object -> S.Set Text -> S.Set Text scanObject o set = let props = (map propToLabel . objProperties) o methods = (map methodToLabel . filterMethods . objMethods) o in S.unions [set, S.fromList props, S.fromList methods] scanInterface :: Interface -> S.Set Text -> S.Set Text scanInterface i set = let props = (map propToLabel . ifProperties) i methods = (map methodToLabel . filterMethods . ifMethods) i in S.unions [set, S.fromList props, S.fromList methods] scanStruct :: Struct -> S.Set Text -> S.Set Text scanStruct s set = let attrs = (map fieldToLabel . filterFields . structFields) s methods = (map methodToLabel . filterMethods . structMethods) s in S.unions [set, S.fromList attrs, S.fromList methods] scanUnion :: Union -> S.Set Text -> S.Set Text scanUnion u set = let attrs = (map fieldToLabel . filterFields . unionFields) u methods = (map methodToLabel . filterMethods . unionMethods) u in S.unions [set, S.fromList attrs, S.fromList methods] propToLabel :: Property -> Text propToLabel = lcFirst . hyphensToCamelCase . propName methodToLabel :: Method -> Text methodToLabel = lowerName . methodName fieldToLabel :: Field -> Text fieldToLabel = lcFirst . underscoresToCamelCase . fieldName filterMethods :: [Method] -> [Method] filterMethods = filter (\m -> (isNothing . methodMovedTo) m && methodType m == OrdinaryMethod) filterFields :: [Field] -> [Field] filterFields = filter (\f -> fieldVisible f && (not . T.null . fieldName) f) genOverloadedLabel :: Text -> CodeGen () genOverloadedLabel l = group $ do line $ "_" <> l <> " :: IsLabelProxy \"" <> l <> "\" a => a" line $ "_" <> l <> " = fromLabelProxy (Proxy :: Proxy \"" <> l <> "\")" export ToplevelSection ("_" <> l) genOverloadedLabels :: [(Name, API)] -> CodeGen () genOverloadedLabels allAPIs = do setLanguagePragmas ["DataKinds", "FlexibleContexts", "CPP"] setModuleFlags [ImplicitPrelude] line $ "import Data.Proxy (Proxy(..))" line $ "import Data.GI.Base.Overloading (IsLabelProxy(..))" blank labels <- findOverloaded allAPIs forM_ labels $ \l -> do genOverloadedLabel l blank haskell-gi-0.21.5/lib/Data/GI/CodeGen/OverloadedMethods.hs0000644000000000000000000001167000000000000021141 0ustar0000000000000000module Data.GI.CodeGen.OverloadedMethods ( genMethodList , genMethodInfo , genUnsupportedMethodInfo ) where import Control.Monad (forM, forM_, when) import Data.Monoid ((<>)) import Data.Text (Text) import qualified Data.Text as T import Data.GI.CodeGen.API import Data.GI.CodeGen.Callable (callableSignature, Signature(..), ForeignSymbol(..), fixupCallerAllocates) import Data.GI.CodeGen.Code import Data.GI.CodeGen.SymbolNaming (lowerName, upperName, qualifiedSymbol) import Data.GI.CodeGen.Util (ucFirst) -- | Qualified name for the info for a given method. methodInfoName :: Name -> Method -> CodeGen 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 () genMethodResolver n = do group $ do line $ "instance (info ~ Resolve" <> n <> "Method t " <> n <> ", " <> "O.MethodInfo info " <> n <> " p) => O.IsLabelProxy t (" <> n <> " -> p) where" indent $ line $ "fromLabelProxy _ = O.overloadedMethod (O.MethodProxy :: O.MethodProxy info)" group $ do line $ "#if MIN_VERSION_base(4,9,0)" line $ "instance (info ~ Resolve" <> n <> "Method t " <> n <> ", " <> "O.MethodInfo info " <> n <> " p) => O.IsLabel t (" <> n <> " -> p) where" line $ "#if MIN_VERSION_base(4,10,0)" indent $ line $ "fromLabel = O.overloadedMethod (O.MethodProxy :: O.MethodProxy info)" line $ "#else" indent $ line $ "fromLabel _ = O.overloadedMethod (O.MethodProxy :: O.MethodProxy info)" line $ "#endif" line $ "#endif" -- | Generate the `MethodList` instance given the list of methods for -- the given named type. genMethodList :: Name -> [(Name, Method)] -> CodeGen () 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" line $ "type family " <> resolver <> " (t :: Symbol) (o :: *) :: * where" indent $ forM_ infos $ \(label, info) -> do line $ resolver <> " \"" <> label <> "\" o = " <> info indent $ line $ resolver <> " l o = O.MethodResolutionFailed l o" genMethodResolver name 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 -- | Generate the `MethodInfo` type and instance for the given method. genMethodInfo :: Name -> Method -> ExcCodeGen () genMethodInfo n m = when (methodType m == OrdinaryMethod) $ group $ do infoName <- methodInfoName n m let callable = fixupCallerAllocates (methodCallable m) sig <- callableSignature callable (KnownForeignSymbol undefined) bline $ "data " <> infoName -- This should not happen, since ordinary methods always -- have the instance as first argument. when (null (signatureArgTypes sig)) $ error $ "Internal error: too few parameters! " ++ show m let (obj:otherTypes) = map snd (signatureArgTypes sig) sigConstraint = "signature ~ (" <> T.intercalate " -> " (otherTypes ++ [signatureReturnType sig]) <> ")" line $ "instance (" <> T.intercalate ", " (sigConstraint : signatureConstraints sig) <> ") => O.MethodInfo " <> infoName <> " " <> obj <> " signature where" let mn = methodName m mangled = lowerName (mn {name = name n <> "_" <> name mn}) indent $ line $ "overloadedMethod _ = " <> mangled 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 () 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 line $ "instance (p ~ (), o ~ O.MethodResolutionFailed \"" <> lowerName (methodName m) <> "\" " <> name n <> ") => O.MethodInfo " <> infoName <> " o p where" indent $ line $ "overloadedMethod _ = undefined" export ToplevelSection infoName haskell-gi-0.21.5/lib/Data/GI/CodeGen/OverloadedSignals.hs0000644000000000000000000001212100000000000021126 0ustar0000000000000000module Data.GI.CodeGen.OverloadedSignals ( genObjectSignals , genInterfaceSignals , genOverloadedSignalConnectors ) where #if !MIN_VERSION_base(4,8,0) import Control.Applicative ((<$>)) #endif import Control.Monad (forM_, when) import Data.Monoid ((<>)) import Data.Text (Text) import qualified Data.Text as T import qualified Data.Set as S 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.Signal (signalHaskellName, genSignalConnector) import Data.GI.CodeGen.SymbolNaming (upperName, hyphensToCamelCase, qualifiedSymbol) import Data.GI.CodeGen.Util (lcFirst, ucFirst) -- A list of distinct signal names for all GObjects appearing in the -- given list of APIs. findSignalNames :: [(Name, API)] -> CodeGen [Text] findSignalNames apis = S.toList <$> go apis S.empty where go :: [(Name, API)] -> S.Set Text -> CodeGen (S.Set Text) go [] set = return set go ((_, api):apis) set = case api of APIInterface iface -> go apis $ insertSignals (ifSignals iface) set APIObject object -> go apis $ insertSignals (objSignals object) set _ -> go apis set insertSignals :: [Signal] -> S.Set Text -> S.Set Text insertSignals props set = foldr (S.insert . sigName) set props -- | Generate the overloaded signal connectors: "Clicked", "ActivateLink", ... genOverloadedSignalConnectors :: [(Name, API)] -> CodeGen () genOverloadedSignalConnectors allAPIs = do setLanguagePragmas ["DataKinds", "PatternSynonyms", "CPP", -- For ghc 7.8 support "RankNTypes", "ScopedTypeVariables", "TypeFamilies"] setModuleFlags [ImplicitPrelude] line "import Data.GI.Base.Signals (SignalProxy(..))" line "import Data.GI.Base.Overloading (ResolveSignal)" blank signalNames <- findSignalNames allAPIs forM_ signalNames $ \sn -> group $ do let camelName = hyphensToCamelCase sn line $ "#if MIN_VERSION_base(4,8,0)" line $ "pattern " <> camelName <> " :: SignalProxy object (ResolveSignal \"" <> lcFirst camelName <> "\" object)" line $ "pattern " <> camelName <> " = SignalProxy" line $ "#else" line $ "pattern " <> camelName <> " = SignalProxy :: forall info object. " <> "info ~ ResolveSignal \"" <> lcFirst camelName <> "\" object => SignalProxy object info" line $ "#endif" exportDecl $ "pattern " <> camelName -- | Qualified name for the "(sigName, info)" tag for a given signal. signalInfoName :: Name -> Signal -> CodeGen Text signalInfoName n signal = do let infoName = upperName n <> (ucFirst . signalHaskellName . sigName) signal <> "SignalInfo" qualifiedSymbol infoName n -- | Generate the given signal instance for the given API object. genInstance :: Name -> Signal -> CodeGen () genInstance owner signal = group $ do let name = upperName owner let sn = (ucFirst . signalHaskellName . sigName) signal 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 = do" indent $ genSignalConnector signal cbHaskellType "connectMode" export (NamedSubsection SignalSection $ lcFirst sn) si -- | Signal instances for (GObject-derived) objects. genObjectSignals :: Name -> Object -> CodeGen () genObjectSignals n o = do let name = upperName n isGO <- apiIsGObject n (APIObject o) when isGO $ do mapM_ (genInstance n) (objSignals o) infos <- fullObjectSignalList n o >>= mapM (\(owner, signal) -> do si <- signalInfoName owner signal return $ "'(\"" <> (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, *)])" -- | Signal instances for interfaces. genInterfaceSignals :: Name -> Interface -> CodeGen () genInterfaceSignals n iface = do let name = upperName n mapM_ (genInstance n) (ifSignals iface) 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, *)])" haskell-gi-0.21.5/lib/Data/GI/CodeGen/Overrides.hs0000644000000000000000000005042600000000000017475 0ustar0000000000000000{-# LANGUAGE ViewPatterns #-} module Data.GI.CodeGen.Overrides ( Overrides(pkgConfigMap, cabalPkgVersion, nsChooseVersion, girFixups, onlineDocsMap) , parseOverridesFile , filterAPIsAndDeps ) where #if !MIN_VERSION_base(4,8,0) import Control.Applicative ((<$>)) import Data.Traversable (traverse) #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 file, filling in the configuration as -- needed. In case the parsing fails we return a description of the -- error instead. parseOverridesFile :: FilePath -> IO (Either Text Overrides) parseOverridesFile fname = do overrides <- utf8ReadFile fname 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 "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.") -- | 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 = liftIO (parseOverridesFile $ T.unpack fname) >>= \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.21.5/lib/Data/GI/CodeGen/PkgConfig.hs0000644000000000000000000000377600000000000017410 0ustar0000000000000000module Data.GI.CodeGen.PkgConfig ( pkgConfigGetVersion , tryPkgConfig ) where import Control.Monad (when) import Data.Monoid (First(..), (<>)) #if !MIN_VERSION_base(4,8,0) import Data.Monoid (mconcat) #endif import qualified Data.Map.Strict as M import qualified Data.Text as T import Data.Text (Text) import System.Exit (ExitCode(..)) import System.Process (readProcessWithExitCode) -- | Try asking pkg-config for the version of a given module, 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.21.5/lib/Data/GI/CodeGen/ProjectInfo.hs0000644000000000000000000006763200000000000017764 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 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, Iñaki García Etxebarria and Jonas Platte" maintainers :: Text maintainers = "Iñaki García Etxebarria (garetxe@gmail.com)" 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"] -- | Extensions that will be used in some modules, but we do not wish -- to turn on by default. otherExtensions :: [Text] otherExtensions = ["PatternSynonyms", "ViewPatterns"] -- | 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 && < 2", "transformers >= 0.4 && < 1"] -- | Under which category in hackage should the generated bindings be listed. category :: Text category = "Bindings" licenseText :: Text licenseText = 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.21.5/lib/Data/GI/CodeGen/Properties.hs0000644000000000000000000004565000000000000017672 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) import Data.Monoid ((<>)) 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.SymbolNaming (lowerName, upperName, classConstraint, typeConstraint, hyphensToCamelCase, qualifiedSymbol, callbackDynamicWrapper) import Data.GI.CodeGen.Type import Data.GI.CodeGen.Util propTypeStr :: Type -> CodeGen 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" 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 error $ "Unboxed struct property : " ++ show t APIUnion u -> if unionIsBoxed u then return "Boxed" else error $ "Unboxed union property : " ++ show t APIObject _ -> do isGO <- isGObject t if isGO then return "Object" else error $ "Non-GObject object property : " ++ show t APIInterface _ -> do isGO <- isGObject t if isGO then return "Object" else error $ "Non-GObject interface property : " ++ show t _ -> error $ "Unknown interface property of type : " ++ show t _ -> error $ "Don't know how to handle properties of type " ++ show t -- | Given a property, return the set of constraints on the types, and -- the type variables for the object and its value. attrType :: Property -> CodeGen ([Text], Text) attrType prop = do isCallback <- typeIsCallback (propType prop) if isCallback then do ftype <- foreignType (propType prop) return ([], typeShow ftype) else do (_,t,constraints) <- argumentType ['a'..'l'] $ propType prop 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 -> CodeGen () 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 = liftIO $ 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 -> CodeGen () 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 <> "\" $ getObjectProperty" <> tStr else "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 = 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 -> CodeGen () 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") : constraints pconstraints = parenthesize (T.intercalate ", " constraints') <> " => " writeHaddock DocBeforeSymbol (constructorDoc prop) line $ constructor <> " :: " <> pconstraints <> t <> " -> IO (GValueConstruct o)" line $ constructor <> " val = constructObjectProperty" <> tStr <> " \"" <> propName prop <> if isNullable && (not isCallback) then "\" (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 -> CodeGen () 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 $ 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 () 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 () 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 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 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 docSection = NamedSubsection PropertySection (lcFirst cName) 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 do inIsGO <- isGObject (propType prop) isCallback <- typeIsCallback (propType prop) hInType <- if isCallback then typeShow <$> foreignType (propType prop) else typeShow <$> haskellType (propType prop) if inIsGO then typeConstraint (propType prop) else return $ "(~) " <> if T.any (== ' ') hInType then parenthesize hInType else hInType 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 bline $ "data " <> it line $ "instance AttrInfo " <> it <> " where" indent $ do line $ "type AttrAllowedOps " <> it <> " = '[ " <> T.intercalate ", " allowedOps <> "]" line $ "type AttrSetTypeConstraint " <> it <> " = " <> inConstraint line $ "type AttrBaseTypeConstraint " <> it <> " = " <> cls line $ "type AttrGetType " <> it <> " = " <> outType line $ "type AttrLabel " <> it <> " = \"" <> propName prop <> "\"" line $ "type AttrOrigin " <> it <> " = " <> name line $ "attrGet _ = " <> getter line $ "attrSet _ = " <> setter line $ "attrConstruct _ = " <> constructor line $ "attrClear _ = " <> clear -- | Generate a placeholder property for those cases in which code -- generation failed. genPlaceholderProperty :: Name -> Property -> CodeGen () genPlaceholderProperty owner prop = do line $ "-- XXX Placeholder" it <- infoType owner prop let cName = (hyphensToCamelCase . propName) prop docSection = NamedSubsection PropertySection (lcFirst cName) export docSection it line $ "data " <> it line $ "instance AttrInfo " <> it <> " where" indent $ do line $ "type AttrAllowedOps " <> it <> " = '[]" line $ "type AttrSetTypeConstraint " <> it <> " = (~) ()" line $ "type AttrBaseTypeConstraint " <> it <> " = (~) ()" line $ "type AttrGetType " <> it <> " = ()" line $ "type AttrLabel " <> it <> " = \"\"" line $ "type AttrOrigin " <> it <> " = " <> upperName owner line $ "attrGet = undefined" line $ "attrSet = undefined" line $ "attrConstruct = undefined" line $ "attrClear = undefined" genProperties :: Name -> [Property] -> [Text] -> CodeGen () 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: " <> describeCGError 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, *)])" -- | 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 () genNamespacedPropLabels owner props methods = let lName = lcFirst . hyphensToCamelCase . propName in genNamespacedAttrLabels owner (map lName props) methods genNamespacedAttrLabels :: Name -> [Text] -> [Method] -> CodeGen () 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.21.5/lib/Data/GI/CodeGen/Signal.hs0000644000000000000000000004544700000000000016757 0ustar0000000000000000module Data.GI.CodeGen.Signal ( genSignal , genSignalConnector , genCallback , signalHaskellName ) where #if !MIN_VERSION_base(4,8,0) import Control.Applicative ((<$>)) #endif import Control.Monad (forM, forM_, when, unless) import Data.Maybe (catMaybes) import Data.Monoid ((<>)) 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, ExposeClosures(..), 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.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 -> Documentation -> ExcCodeGen () genHaskellCallbackPrototype subsec cb htype expose 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 <- haskellType (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 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 -> Bool -> CodeGen Text genCCallbackPrototype subsec cb name' isSignal = group $ do let ctypeName = callbackCType name' export (NamedSubsection SignalSection subsec) ctypeName writeHaddock DocBeforeSymbol ccallbackDoc line $ "type " <> ctypeName <> " =" indent $ do when isSignal $ line $ withComment "Ptr () ->" "object" forM_ (args cb) $ \arg -> do ht <- foreignType $ argType arg let ht' = if direction arg /= DirectionIn then ptr ht else ht line $ typeShow ht' <> " ->" when (callableThrows cb) $ line "Ptr (Ptr GError) ->" when isSignal $ 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 -> CodeGen () genCallbackWrapperFactory subsec name' = group $ do let factoryName = callbackWrapperAllocator name' writeHaddock DocBeforeSymbol factoryDoc line "foreign import ccall \"wrapper\"" indent $ line $ factoryName <> " :: " <> callbackCType name' <> " -> IO (FunPtr " <> callbackCType name' <> ")" 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 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 -> Bool -> CodeGen () genClosure subsec cb callback name isSignal = group $ do let closure = callbackClosureGenerator name export (NamedSubsection SignalSection subsec) closure writeHaddock DocBeforeSymbol closureDoc group $ do line $ closure <> " :: " <> callback <> " -> IO Closure" line $ closure <> " cb = do" indent $ do wrapped <- genWrappedCallback cb "cb" callback isSignal line $ callbackWrapperAllocator callback <> " " <> wrapped <> " >>= newCClosure" where closureDoc :: Text closureDoc = "Wrap the callback into a `Closure`." -- Wrap a conversion of a nullable object into "Maybe" object, by -- checking whether the pointer is NULL. convertNullable :: Text -> BaseCodeGen e Text -> BaseCodeGen e Text convertNullable aname c = do line $ "maybe" <> ucFirst aname <> " <-" indent $ do line $ "if " <> aname <> " == nullPtr" line "then return Nothing" line "else do" indent $ do unpacked <- c line $ "return $ Just " <> unpacked return $ "maybe" <> ucFirst aname -- Convert a non-zero terminated out array, stored in a variable -- named "aname", into the corresponding Haskell object. convertCallbackInCArray :: Callable -> Arg -> Type -> Text -> ExcCodeGen Text convertCallbackInCArray callable arg t@(TCArray False (-1) length _) aname = if length > -1 then wrapMaybe arg >>= bool convertAndFree (convertNullable aname convertAndFree) else -- Not much we can do, we just pass the pointer along, and let -- the callback deal with it. return aname where lname = 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) 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 () 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 -> Bool -> ExcCodeGen () genCallbackWrapper subsec cb name' isSignal = group $ do let wrapperName = callbackHaskellToForeign name' (hInArgs, _) = callableHInArgs cb WithClosures hOutArgs = callableHOutArgs cb wrapperDoc = "Wrap a `" <> name' <> "` into a `" <> callbackCType name' <> "`." export (NamedSubsection SignalSection subsec) wrapperName writeHaddock DocBeforeSymbol wrapperDoc group $ do line $ wrapperName <> " ::" indent $ do if isSignal then do line $ 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 $ ["_cb", "_"] <> cArgNames <> ["_"] else T.unwords $ ["funptrptr", "_cb"] <> cArgNames line $ wrapperName <> " " <> allArgs <> " = do" 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 <> " <- " line $ returnBind <> "_cb " <> T.concat (map (" " <>) hInNames) forM_ hOutArgs saveOutArg unless isSignal $ line "maybeReleaseFunPtr funptrptr" case returnType cb of Nothing -> return () Just r -> do nullableReturnType <- typeIsNullable r if returnMayBeNull cb && nullableReturnType then do line "maybeM 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 () genCallback n (Callback {cbCallable = cb, cbDocumentation = cbDoc }) = do let name' = upperName n line $ "-- callback " <> name' line $ "-- -> " <> tshow (fixupCallerAllocates cb) 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 let cb' = fixupCallerAllocates cb handleCGExc (\e -> line ("-- XXX Could not generate callback wrapper for " <> name' <> "\n-- Error was : " <> describeCGError e)) $ do typeSynonym <- genCCallbackPrototype name' cb' name' False dynamic <- genDynamicCallableWrapper n typeSynonym cb export (NamedSubsection SignalSection name') dynamic genCallbackWrapperFactory name' name' deprecatedPragma name' (callableDeprecated cb') genHaskellCallbackPrototype name' cb' name' WithoutClosures cbDoc when (callableHasClosures cb') $ do genHaskellCallbackPrototype name' cb' name' WithClosures 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' False genCallbackWrapper name' cb' name' False -- | Return the name for the signal in Haskell CamelCase conventions. signalHaskellName :: Text -> Text signalHaskellName sn = let (w:ws) = T.split (== '-') sn in w <> T.concat (map ucFirst ws) genSignal :: Signal -> Name -> ExcCodeGen () genSignal s@(Signal { sigName = sn, sigCallable = cb }) 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 (sigDoc s) _ <- genCCallbackPrototype (lcFirst sn') cb cbType True genCallbackWrapperFactory (lcFirst sn') cbType if callableThrows cb then do line $ "-- No Haskell->C wrapper generated since the function throws." blank else do genClosure (lcFirst sn') cb cbType signalConnectorName True genCallbackWrapper (lcFirst sn') cb cbType True -- Wrapper for connecting functions to the signal -- We can connect to a signal either before the default handler runs -- ("on...") or after the default handler runs (after...). We -- provide convenient wrappers for both cases. group $ do -- Notice that we do not include GObject here as a constraint, -- since if something provides signals it is necessarily a -- GObject. klass <- classConstraint on let signatureConstraints = "(" <> klass <> " a, MonadIO m) =>" signatureArgs = "a -> " <> cbType <> " -> m SignalHandlerId" signature = " :: " <> signatureConstraints <> " " <> signatureArgs onName = "on" <> signalConnectorName afterName = "after" <> signalConnectorName group $ do writeHaddock DocBeforeSymbol onDoc line $ onName <> signature line $ onName <> " obj cb = liftIO $ do" indent $ genSignalConnector s cbType "SignalConnectBefore" export docSection onName group $ do writeHaddock DocBeforeSymbol afterDoc line $ afterName <> signature line $ afterName <> " obj cb = liftIO $ do" indent $ genSignalConnector s cbType "SignalConnectAfter" export docSection afterName where onDoc :: Text onDoc = T.unlines [ "Connect a signal handler for the “@" <> sn <> "@” signal, to be run before the default handler." , "When is enabled, this is equivalent to" , "" , "@" , "'Data.GI.Base.Signals.on' " <> lowerName on <> " #" <> lcFirst (hyphensToCamelCase sn) <> " callback" , "@" ] afterDoc :: Text afterDoc = T.unlines [ "Connect a signal handler for the “@" <> sn <> "@” signal, to be run after the default handler." , "When is enabled, this is equivalent to" , "" , "@" , "'Data.GI.Base.Signals.after' " <> lowerName on <> " #" <> lcFirst (hyphensToCamelCase sn) <> " callback" , "@" ] -- | 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 -> CodeGen () genSignalConnector (Signal {sigName = sn, sigCallable = cb}) cbType when = do cb' <- genWrappedCallback cb "cb" cbType True let cb'' = prime cb' line $ cb'' <> " <- " <> callbackWrapperAllocator cbType <> " " <> cb' line $ "connectSignalFunPtr obj \"" <> sn <> "\" " <> cb'' <> " " <> when haskell-gi-0.21.5/lib/Data/GI/CodeGen/Struct.hs0000644000000000000000000004275500000000000017025 0ustar0000000000000000-- | Marshalling of structs and unions. module Data.GI.CodeGen.Struct ( genStructOrUnionFields , genZeroStruct , genZeroUnion , extractCallbacksInStruct , fixAPIStructs , ignoreStruct , genWrappedPtr ) where #if !MIN_VERSION_base(4,8,0) import Control.Applicative ((<$>)) #endif import Control.Monad (forM, when) import Data.Maybe (mapMaybe, isJust, catMaybes) import Data.Monoid ((<>)) 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.SymbolNaming 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 -- | 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 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 <> ")" -- | 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) line $ "data " <> it line $ "instance AttrInfo " <> it <> " where" indent $ do 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 AttrBaseTypeConstraint " <> it <> " = (~) " <> on 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" 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 <> ")" buildFieldAttributes :: Name -> Field -> ExcCodeGen (Maybe Text) buildFieldAttributes n field | not (fieldVisible field) = return Nothing | privateType (fieldType field) = return Nothing | otherwise = group $ do 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 genStructOrUnionFields :: Name -> [Field] -> CodeGen () genStructOrUnionFields n fields = do let name' = upperName n attrs <- forM fields $ \field -> handleCGExc (\e -> line ("-- XXX Skipped attribute for \"" <> name' <> ":" <> fieldName field <> "\" :: " <> describeCGError 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, *)])" -- | 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 () 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 "wrappedPtrCalloc >>= 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 () 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 () 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 Text prefixedForeignImport prefix symbol prototype = group $ do line $ "foreign import ccall \"" <> symbol <> "\" " <> prefix <> symbol <> " :: " <> prototype return (prefix <> symbol) -- | Same as `prefixedForeignImport`, but import a `FunPtr` to the symbol. prefixedFunPtrImport :: Text -> Text -> Text -> CodeGen Text prefixedFunPtrImport prefix symbol prototype = group $ do line $ "foreign import ccall \"&" <> symbol <> "\" " <> prefix <> symbol <> " :: FunPtr (" <> prototype <> ")" return (prefix <> symbol) -- | Generate the typeclass with information for how to -- allocate/deallocate a given type. genWrappedPtr :: Name -> AllocationInfo -> Int -> CodeGen () genWrappedPtr n info size = group $ do let name' = upperName n 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?" calloc <- case allocCalloc info of AllocationOp "none" -> return ("error \"calloc not permitted for " <> name' <> "\"") AllocationOp op -> prefixedForeignImport (prefix "calloc") op "IO (Ptr a)" AllocationOpUnknown -> if size > 0 then return ("callocBytes " <> tshow size) else return "return nullPtr" copy <- case allocCopy info of AllocationOp op -> do copy <- prefixedForeignImport (prefix "copy") op "Ptr a -> IO (Ptr a)" return ("\\p -> withManagedPtr p (" <> copy <> " >=> wrapPtr " <> name' <> ")") AllocationOpUnknown -> if size > 0 then return ("\\p -> withManagedPtr p (copyBytes " <> tshow size <> " >=> wrapPtr " <> name' <> ")") else return "return" free <- case allocFree info of AllocationOp op -> ("Just " <>) <$> prefixedFunPtrImport (prefix "free") op "Ptr a -> IO ()" AllocationOpUnknown -> if size > 0 then return "Just ptr_to_g_free" else return "Nothing" line $ "instance WrappedPtr " <> name' <> " where" indent $ do line $ "wrappedPtrCalloc = " <> calloc line $ "wrappedPtrCopy = " <> copy line $ "wrappedPtrFree = " <> free hsBoot $ line $ "instance WrappedPtr " <> name' <> " where" haskell-gi-0.21.5/lib/Data/GI/CodeGen/SymbolNaming.hs0000644000000000000000000002033600000000000020127 0ustar0000000000000000{-# LANGUAGE ViewPatterns #-} module Data.GI.CodeGen.SymbolNaming ( lowerName , lowerSymbol , upperName , noName , escapedArgName , classConstraint , typeConstraint , hyphensToCamelCase , underscoresToCamelCase , callbackCType , callbackHTypeWithClosures , callbackDropClosures , callbackDynamicWrapper , callbackWrapperAllocator , callbackHaskellToForeign , callbackHaskellToForeignWithClosures , callbackClosureGenerator , submoduleLocation , qualifiedAPI , qualifiedSymbol ) where import Data.Monoid ((<>)) import Data.Text (Text) import qualified Data.Text as T import Data.GI.CodeGen.API import Data.GI.CodeGen.Code (CodeGen, group, line, exportDecl, qualified, getAPI) import Data.GI.CodeGen.ModulePath (ModulePath, (/.), toModulePath) 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 Text classConstraint n@(Name _ s) = qualifiedSymbol ("Is" <> 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 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 -- | Return an identifier for the given interface type valid in the current -- module. qualifiedAPI :: Name -> CodeGen Text qualifiedAPI n@(Name ns _) = do api <- getAPI (TInterface n) qualified (toModulePath (ucFirst ns) <> submoduleLocation n api) n -- | Construct an identifier for the given symbol in the given API. qualifiedSymbol :: Text -> Name -> CodeGen Text qualifiedSymbol s n@(Name ns _) = do api <- getAPI (TInterface n) qualified (toModulePath (ucFirst ns) <> submoduleLocation n api) (Name ns s) -- | Save a bit of typing for optional arguments in the case that we -- want to pass Nothing. noName :: Text -> CodeGen () noName name' = group $ do -- We should use `writeHaddock` here, but it would give rise to a -- cyclic import. line $ "-- | A convenience alias for `Nothing` :: `Maybe` `" <> name' <> "`." line $ "no" <> name' <> " :: Maybe " <> name' line $ "no" <> name' <> " = Nothing" exportDecl ("no" <> name') -- | 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 | "_" `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 haskell-gi-0.21.5/lib/Data/GI/CodeGen/Transfer.hs0000644000000000000000000002525000000000000017314 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) import Data.Monoid ((<>)) 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 (TParamSpec) = Nothing -- Basic free primitives in the case that an error occured. This is -- run in the exception handler, so any type which we ref/allocate -- with the expectation that the called function will consume it (on -- TransferEverything) should be freed here. basicFreeFnOnError :: Type -> Transfer -> CodeGen (Maybe 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 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 [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 [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 need to be freed, they -- will always be soaked up by the wrapPtr constructor, or they will -- be DirectionIn. if not (argCallerAllocates arg) then case direction arg of DirectionIn -> freeIn (transfer arg) (argType arg) label len DirectionOut -> freeOut label DirectionInout -> freeOut label else return [] -- | Same thing as freeInArg, but called in case the call to C didn't -- succeed. We thus free everything we allocated in preparation for -- the call, including args that would have been transferred to C. freeInArgOnError :: Arg -> 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.21.5/lib/Data/GI/CodeGen/Type.hs0000644000000000000000000000461200000000000016450 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 import Data.Monoid ((<>)) 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.21.5/lib/Data/GI/CodeGen/Util.hs0000644000000000000000000000463500000000000016451 0ustar0000000000000000module Data.GI.CodeGen.Util ( prime , parenthesize , padTo , withComment , ucFirst , lcFirst , modifyQualified , tshow , terror , utf8ReadFile , utf8WriteFile , splitOn ) where import Data.Monoid ((<>)) 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 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 -- | Throw an error with the given `Text`. terror :: Text -> a terror = error . T.unpack -- | 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) haskell-gi-0.21.5/lib/Data/GI/GIR/0000755000000000000000000000000000000000000014305 5ustar0000000000000000haskell-gi-0.21.5/lib/Data/GI/GIR/Alias.hs0000644000000000000000000000275200000000000015700 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.21.5/lib/Data/GI/GIR/Allocation.hs0000644000000000000000000000213300000000000016725 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.21.5/lib/Data/GI/GIR/Arg.hs0000644000000000000000000000527700000000000015365 0ustar0000000000000000module Data.GI.GIR.Arg ( Arg(..) , Direction(..) , Scope(..) , parseArg , parseTransfer ) where import Data.Monoid ((<>)) 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 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, transfer :: Transfer } deriving (Show, Eq, Ord) parseTransfer :: Parser Transfer parseTransfer = getAttr "transfer-ownership" >>= \case "none" -> return TransferNothing "container" -> return TransferContainer "full" -> return TransferEverything t -> parseError $ "Unknown transfer type \"" <> t <> "\"" parseScope :: Text -> Parser Scope parseScope "call" = return ScopeTypeCall parseScope "async" = return ScopeTypeAsync parseScope "notified" = return ScopeTypeNotified 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 callerAllocates <- optionalAttr "caller-allocates" False parseBool t <- parseType doc <- parseDocumentation return $ Arg { argCName = name , argType = t , argDoc = doc , direction = d , mayBeNull = nullable , argScope = scope , argClosure = closure , argDestroy = destroy , argCallerAllocates = callerAllocates , transfer = ownership } haskell-gi-0.21.5/lib/Data/GI/GIR/BasicTypes.hs0000644000000000000000000000474500000000000016721 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 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 | 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 | TInterface Name -- ^ A reference to some API in the GIR deriving (Eq, Show, Ord) haskell-gi-0.21.5/lib/Data/GI/GIR/Callable.hs0000644000000000000000000000446200000000000016346 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 } 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 } haskell-gi-0.21.5/lib/Data/GI/GIR/Callback.hs0000644000000000000000000000137000000000000016336 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.21.5/lib/Data/GI/GIR/Constant.hs0000644000000000000000000000206700000000000016437 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, parseCType) 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 ctype <- parseCType doc <- parseDocumentation return (name, Constant { constantType = t , constantValue = value , constantCType = ctype , constantDocumentation = doc , constantDeprecated = deprecated }) haskell-gi-0.21.5/lib/Data/GI/GIR/Deprecation.hs0000644000000000000000000000171400000000000017101 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.21.5/lib/Data/GI/GIR/Documentation.hs0000644000000000000000000000174500000000000017461 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.21.5/lib/Data/GI/GIR/Enum.hs0000644000000000000000000000441600000000000015552 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.21.5/lib/Data/GI/GIR/Field.hs0000644000000000000000000000625700000000000015676 0ustar0000000000000000-- | Parsing of object/struct/union fields. module Data.GI.GIR.Field ( Field(..) , FieldInfoFlag , parseFields ) where import Data.Maybe (isJust) import Data.Monoid ((<>)) 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 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 (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 $ 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 = parseAllChildrenWithLocalName "field" parseField haskell-gi-0.21.5/lib/Data/GI/GIR/Flags.hs0000644000000000000000000000065700000000000015705 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.21.5/lib/Data/GI/GIR/Function.hs0000644000000000000000000000150600000000000016430 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 { 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.21.5/lib/Data/GI/GIR/Interface.hs0000644000000000000000000000343700000000000016550 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.21.5/lib/Data/GI/GIR/Method.hs0000644000000000000000000000367200000000000016071 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, 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.21.5/lib/Data/GI/GIR/Object.hs0000644000000000000000000000356100000000000016054 0ustar0000000000000000-- | Parsing of objects. module Data.GI.GIR.Object ( Object(..) , parseObject ) where 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, 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 typeInit <- getAttrWithNamespace GLibGIRNS "get-type" typeName <- getAttrWithNamespace GLibGIRNS "type-name" signals <- parseChildrenWithNSName GLibGIRNS "signal" parseSignal ctype <- queryCType return (name, Object { objParent = parent , objTypeInit = typeInit , objCType = ctype , objTypeName = typeName , objInterfaces = interfaces , objDeprecated = deprecated , objDocumentation = doc , objMethods = constructors ++ methods ++ functions , objProperties = props , objSignals = signals }) haskell-gi-0.21.5/lib/Data/GI/GIR/Parser.hs0000644000000000000000000002066400000000000016105 0ustar0000000000000000-- | The Parser monad. module Data.GI.GIR.Parser ( Parser , 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 #if !MIN_VERSION_base(4,8,0) import Control.Applicative ((<$>)) #endif import Control.Monad.Except import Control.Monad.Reader import Data.Monoid ((<>)) import qualified Data.Map as M import qualified Data.Text as T import qualified Data.Text.Read as TR import Data.Text (Text) import qualified Text.XML as XML import Text.XML (Element(elementAttributes)) import Text.Show.Pretty (ppShow) import 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.21.5/lib/Data/GI/GIR/Property.hs0000644000000000000000000000360300000000000016467 0ustar0000000000000000module Data.GI.GIR.Property ( Property(..) , PropertyFlag(..) , parseProperty ) where import Data.Text (Text) import Data.Monoid ((<>)) import Data.GI.GIR.Arg (parseTransfer) 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 <- parseTransfer deprecated <- parseDeprecation readable <- optionalAttr "readable" True parseBool writable <- optionalAttr "writable" False parseBool construct <- optionalAttr "construct" False parseBool constructOnly <- optionalAttr "construct-only" False parseBool 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 -- No support in the GIR for nullability info , propReadNullable = Nothing , propWriteNullable = Nothing } haskell-gi-0.21.5/lib/Data/GI/GIR/Repository.hs0000644000000000000000000000674500000000000017034 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) girDataDirs :: IO [FilePath] girDataDirs = getSystemDataDirs "gir-1.0" -- | 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.21.5/lib/Data/GI/GIR/Signal.hs0000644000000000000000000000130000000000000016050 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, sigDoc :: Documentation } deriving (Show, Eq) parseSignal :: Parser Signal parseSignal = do n <- getAttr "name" deprecated <- parseDeprecation callable <- parseCallable doc <- parseDocumentation return $ Signal { sigName = n , sigCallable = callable , sigDeprecated = deprecated , sigDoc = doc } haskell-gi-0.21.5/lib/Data/GI/GIR/Struct.hs0000644000000000000000000000414600000000000016132 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, 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 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 , structFields = fields , structMethods = constructors ++ methods ++ functions , structDeprecated = deprecated , structDocumentation = doc }) haskell-gi-0.21.5/lib/Data/GI/GIR/Type.hs0000644000000000000000000001737300000000000015575 0ustar0000000000000000{-# LANGUAGE RecordWildCards, PatternGuards #-} -- | Parsing type information from GIR files. module Data.GI.GIR.Type ( parseType , queryCType , parseCType , queryElementCType , parseOptionalType ) where #if !MIN_VERSION_base(4,8,0) import Control.Applicative ((<$>)) #endif import Data.Maybe (catMaybes) import Data.Monoid ((<>)) import Data.Text (Text) import qualified Data.Text as T import Foreign.Storable (sizeOf) import Foreign.C (CShort, CUShort, CSize) import System.Posix.Types (CSsize) 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" = case sizeOf (0 :: CShort) of 2 -> Just TInt16 4 -> Just TInt32 8 -> Just TInt64 n -> error $ "Unexpected short size: " ++ show n nameToBasicType "gushort" = case sizeOf (0 :: CUShort) of 2 -> Just TUInt16 4 -> Just TUInt32 8 -> Just TUInt64 n -> error $ "Unexpected ushort size: " ++ show n nameToBasicType "gssize" = case sizeOf (0 :: CSsize) of 4 -> Just TInt32 8 -> Just TInt64 n -> error $ "Unexpected ssize length: " ++ show n nameToBasicType "gsize" = case sizeOf (0 :: CSize) of 4 -> Just TUInt32 8 -> Just TUInt64 n -> error $ "Unexpected size length: " ++ show n nameToBasicType _ = Nothing -- | The different array types. parseArrayInfo :: Parser Type parseArrayInfo = queryAttr "name" >>= \case Just "GLib.Array" -> TGArray <$> parseType Just "GLib.PtrArray" -> TPtrArray <$> parseType Just "GLib.ByteArray" -> return TByteArray Just other -> parseError $ "Unsupported array type: \"" <> other <> "\"" Nothing -> parseCArrayType -- | A C array parseCArrayType :: Parser Type parseCArrayType = do zeroTerminated <- queryAttr "zero-terminated" >>= \case Just b -> parseBool b Nothing -> return True length <- queryAttr "length" >>= \case Just l -> parseIntegral l Nothing -> return (-1) fixedSize <- queryAttr "fixed-size" >>= \case Just s -> parseIntegral s Nothing -> return (-1) elementType <- parseType return $ TCArray zeroTerminated fixedSize length elementType -- | A hash table. parseHashTable :: Parser Type parseHashTable = parseTypeElements >>= \case [Just key, Just value] -> return $ TGHash key value other -> parseError $ "Unsupported hash type: " <> T.pack (show other) -- | For GLists and GSLists there is sometimes no information about -- the type of the elements. In these cases we report them as -- pointers. parseListType :: Parser Type parseListType = queryType >>= \case Just t -> return t Nothing -> return (TBasicType 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 -- A TInterface type (basically, everything that is not of a known type). parseFundamentalType ns n = resolveQualifiedTypeName (Name ns n) -- | 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 <$> case nameToBasicType typeName of Just b -> return (TBasicType b) Nothing -> case T.split ('.' ==) typeName of [ns, n] -> parseFundamentalType ns n [n] -> do ns <- currentNamespace parseFundamentalType ns n _ -> parseError $ "Unsupported type form: \"" <> typeName <> "\"" -- | Find the children giving the type of the given element. parseTypeElements :: Parser [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.21.5/lib/Data/GI/GIR/Union.hs0000644000000000000000000000321200000000000015727 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.21.5/lib/Data/GI/GIR/XMLUtils.hs0000644000000000000000000000677200000000000016336 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.21.5/lib/c/0000755000000000000000000000000000000000000012736 5ustar0000000000000000haskell-gi-0.21.5/lib/c/enumStorage.c0000644000000000000000000000621300000000000015375 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); } }