diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,502 @@ + GNU LESSER GENERAL PUBLIC LICENSE + Version 2.1, February 1999 + + Copyright (C) 1991, 1999 Free Software Foundation, Inc. + 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + +[This is the first released version of the Lesser GPL. It also counts + as the successor of the GNU Library Public License, version 2, hence + the version number 2.1.] + + Preamble + + The licenses for most software are designed to take away your +freedom to share and change it. By contrast, the GNU General Public +Licenses are intended to guarantee your freedom to share and change +free software--to make sure the software is free for all its users. + + This license, the Lesser General Public License, applies to some +specially designated software packages--typically libraries--of the +Free Software Foundation and other authors who decide to use it. You +can use it too, but we suggest you first think carefully about whether +this license or the ordinary General Public License is the better +strategy to use in any particular case, based on the explanations below. + + When we speak of free software, we are referring to freedom of use, +not price. Our General Public Licenses are designed to make sure that +you have the freedom to distribute copies of free software (and charge +for this service if you wish); that you receive source code or can get +it if you want it; that you can change the software and use pieces of +it in new free programs; and that you are informed that you can do +these things. + + To protect your rights, we need to make restrictions that forbid +distributors to deny you these rights or to ask you to surrender these +rights. These restrictions translate to certain responsibilities for +you if you distribute copies of the library or if you modify it. + + For example, if you distribute copies of the library, whether gratis +or for a fee, you must give the recipients all the rights that we gave +you. You must make sure that they, too, receive or can get the source +code. If you link other code with the library, you must provide +complete object files to the recipients, so that they can relink them +with the library after making changes to the library and recompiling +it. And you must show them these terms so they know their rights. + + We protect your rights with a two-step method: (1) we copyright the +library, and (2) we offer you this license, which gives you legal +permission to copy, distribute and/or modify the library. + + To protect each distributor, we want to make it very clear that +there is no warranty for the free library. Also, if the library is +modified by someone else and passed on, the recipients should know +that what they have is not the original version, so that the original +author's reputation will not be affected by problems that might be +introduced by others. + + Finally, software patents pose a constant threat to the existence of +any free program. We wish to make sure that a company cannot +effectively restrict the users of a free program by obtaining a +restrictive license from a patent holder. Therefore, we insist that +any patent license obtained for a version of the library must be +consistent with the full freedom of use specified in this license. + + Most GNU software, including some libraries, is covered by the +ordinary GNU General Public License. This license, the GNU Lesser +General Public License, applies to certain designated libraries, and +is quite different from the ordinary General Public License. We use +this license for certain libraries in order to permit linking those +libraries into non-free programs. + + When a program is linked with a library, whether statically or using +a shared library, the combination of the two is legally speaking a +combined work, a derivative of the original library. The ordinary +General Public License therefore permits such linking only if the +entire combination fits its criteria of freedom. The Lesser General +Public License permits more lax criteria for linking other code with +the library. + + We call this license the "Lesser" General Public License because it +does Less to protect the user's freedom than the ordinary General +Public License. It also provides other free software developers Less +of an advantage over competing non-free programs. These disadvantages +are the reason we use the ordinary General Public License for many +libraries. However, the Lesser license provides advantages in certain +special circumstances. + + For example, on rare occasions, there may be a special need to +encourage the widest possible use of a certain library, so that it becomes +a de-facto standard. To achieve this, non-free programs must be +allowed to use the library. A more frequent case is that a free +library does the same job as widely used non-free libraries. In this +case, there is little to gain by limiting the free library to free +software only, so we use the Lesser General Public License. + + In other cases, permission to use a particular library in non-free +programs enables a greater number of people to use a large body of +free software. For example, permission to use the GNU C Library in +non-free programs enables many more people to use the whole GNU +operating system, as well as its variant, the GNU/Linux operating +system. + + Although the Lesser General Public License is Less protective of the +users' freedom, it does ensure that the user of a program that is +linked with the Library has the freedom and the wherewithal to run +that program using a modified version of the Library. + + The precise terms and conditions for copying, distribution and +modification follow. Pay close attention to the difference between a +"work based on the library" and a "work that uses the library". The +former contains code derived from the library, whereas the latter must +be combined with the library in order to run. + + GNU LESSER GENERAL PUBLIC LICENSE + TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION + + 0. This License Agreement applies to any software library or other +program which contains a notice placed by the copyright holder or +other authorized party saying it may be distributed under the terms of +this Lesser General Public License (also called "this License"). +Each licensee is addressed as "you". + + A "library" means a collection of software functions and/or data +prepared so as to be conveniently linked with application programs +(which use some of those functions and data) to form executables. + + The "Library", below, refers to any such software library or work +which has been distributed under these terms. A "work based on the +Library" means either the Library or any derivative work under +copyright law: that is to say, a work containing the Library or a +portion of it, either verbatim or with modifications and/or translated +straightforwardly into another language. (Hereinafter, translation is +included without limitation in the term "modification".) + + "Source code" for a work means the preferred form of the work for +making modifications to it. For a library, complete source code means +all the source code for all modules it contains, plus any associated +interface definition files, plus the scripts used to control compilation +and installation of the library. + + Activities other than copying, distribution and modification are not +covered by this License; they are outside its scope. The act of +running a program using the Library is not restricted, and output from +such a program is covered only if its contents constitute a work based +on the Library (independent of the use of the Library in a tool for +writing it). Whether that is true depends on what the Library does +and what the program that uses the Library does. + + 1. You may copy and distribute verbatim copies of the Library's +complete source code as you receive it, in any medium, provided that +you conspicuously and appropriately publish on each copy an +appropriate copyright notice and disclaimer of warranty; keep intact +all the notices that refer to this License and to the absence of any +warranty; and distribute a copy of this License along with the +Library. + + You may charge a fee for the physical act of transferring a copy, +and you may at your option offer warranty protection in exchange for a +fee. + + 2. You may modify your copy or copies of the Library or any portion +of it, thus forming a work based on the Library, and copy and +distribute such modifications or work under the terms of Section 1 +above, provided that you also meet all of these conditions: + + a) The modified work must itself be a software library. + + b) You must cause the files modified to carry prominent notices + stating that you changed the files and the date of any change. + + c) You must cause the whole of the work to be licensed at no + charge to all third parties under the terms of this License. + + d) If a facility in the modified Library refers to a function or a + table of data to be supplied by an application program that uses + the facility, other than as an argument passed when the facility + is invoked, then you must make a good faith effort to ensure that, + in the event an application does not supply such function or + table, the facility still operates, and performs whatever part of + its purpose remains meaningful. + + (For example, a function in a library to compute square roots has + a purpose that is entirely well-defined independent of the + application. Therefore, Subsection 2d requires that any + application-supplied function or table used by this function must + be optional: if the application does not supply it, the square + root function must still compute square roots.) + +These requirements apply to the modified work as a whole. If +identifiable sections of that work are not derived from the Library, +and can be reasonably considered independent and separate works in +themselves, then this License, and its terms, do not apply to those +sections when you distribute them as separate works. But when you +distribute the same sections as part of a whole which is a work based +on the Library, the distribution of the whole must be on the terms of +this License, whose permissions for other licensees extend to the +entire whole, and thus to each and every part regardless of who wrote +it. + +Thus, it is not the intent of this section to claim rights or contest +your rights to work written entirely by you; rather, the intent is to +exercise the right to control the distribution of derivative or +collective works based on the Library. + +In addition, mere aggregation of another work not based on the Library +with the Library (or with a work based on the Library) on a volume of +a storage or distribution medium does not bring the other work under +the scope of this License. + + 3. You may opt to apply the terms of the ordinary GNU General Public +License instead of this License to a given copy of the Library. To do +this, you must alter all the notices that refer to this License, so +that they refer to the ordinary GNU General Public License, version 2, +instead of to this License. (If a newer version than version 2 of the +ordinary GNU General Public License has appeared, then you can specify +that version instead if you wish.) Do not make any other change in +these notices. + + Once this change is made in a given copy, it is irreversible for +that copy, so the ordinary GNU General Public License applies to all +subsequent copies and derivative works made from that copy. + + This option is useful when you wish to copy part of the code of +the Library into a program that is not a library. + + 4. You may copy and distribute the Library (or a portion or +derivative of it, under Section 2) in object code or executable form +under the terms of Sections 1 and 2 above provided that you accompany +it with the complete corresponding machine-readable source code, which +must be distributed under the terms of Sections 1 and 2 above on a +medium customarily used for software interchange. + + If distribution of object code is made by offering access to copy +from a designated place, then offering equivalent access to copy the +source code from the same place satisfies the requirement to +distribute the source code, even though third parties are not +compelled to copy the source along with the object code. + + 5. A program that contains no derivative of any portion of the +Library, but is designed to work with the Library by being compiled or +linked with it, is called a "work that uses the Library". Such a +work, in isolation, is not a derivative work of the Library, and +therefore falls outside the scope of this License. + + However, linking a "work that uses the Library" with the Library +creates an executable that is a derivative of the Library (because it +contains portions of the Library), rather than a "work that uses the +library". The executable is therefore covered by this License. +Section 6 states terms for distribution of such executables. + + When a "work that uses the Library" uses material from a header file +that is part of the Library, the object code for the work may be a +derivative work of the Library even though the source code is not. +Whether this is true is especially significant if the work can be +linked without the Library, or if the work is itself a library. The +threshold for this to be true is not precisely defined by law. + + If such an object file uses only numerical parameters, data +structure layouts and accessors, and small macros and small inline +functions (ten lines or less in length), then the use of the object +file is unrestricted, regardless of whether it is legally a derivative +work. (Executables containing this object code plus portions of the +Library will still fall under Section 6.) + + Otherwise, if the work is a derivative of the Library, you may +distribute the object code for the work under the terms of Section 6. +Any executables containing that work also fall under Section 6, +whether or not they are linked directly with the Library itself. + + 6. As an exception to the Sections above, you may also combine or +link a "work that uses the Library" with the Library to produce a +work containing portions of the Library, and distribute that work +under terms of your choice, provided that the terms permit +modification of the work for the customer's own use and reverse +engineering for debugging such modifications. + + You must give prominent notice with each copy of the work that the +Library is used in it and that the Library and its use are covered by +this License. You must supply a copy of this License. If the work +during execution displays copyright notices, you must include the +copyright notice for the Library among them, as well as a reference +directing the user to the copy of this License. Also, you must do one +of these things: + + a) Accompany the work with the complete corresponding + machine-readable source code for the Library including whatever + changes were used in the work (which must be distributed under + Sections 1 and 2 above); and, if the work is an executable linked + with the Library, with the complete machine-readable "work that + uses the Library", as object code and/or source code, so that the + user can modify the Library and then relink to produce a modified + executable containing the modified Library. (It is understood + that the user who changes the contents of definitions files in the + Library will not necessarily be able to recompile the application + to use the modified definitions.) + + b) Use a suitable shared library mechanism for linking with the + Library. A suitable mechanism is one that (1) uses at run time a + copy of the library already present on the user's computer system, + rather than copying library functions into the executable, and (2) + will operate properly with a modified version of the library, if + the user installs one, as long as the modified version is + interface-compatible with the version that the work was made with. + + c) Accompany the work with a written offer, valid for at + least three years, to give the same user the materials + specified in Subsection 6a, above, for a charge no more + than the cost of performing this distribution. + + d) If distribution of the work is made by offering access to copy + from a designated place, offer equivalent access to copy the above + specified materials from the same place. + + e) Verify that the user has already received a copy of these + materials or that you have already sent this user a copy. + + For an executable, the required form of the "work that uses the +Library" must include any data and utility programs needed for +reproducing the executable from it. However, as a special exception, +the materials to be distributed need not include anything that is +normally distributed (in either source or binary form) with the major +components (compiler, kernel, and so on) of the operating system on +which the executable runs, unless that component itself accompanies +the executable. + + It may happen that this requirement contradicts the license +restrictions of other proprietary libraries that do not normally +accompany the operating system. Such a contradiction means you cannot +use both them and the Library together in an executable that you +distribute. + + 7. You may place library facilities that are a work based on the +Library side-by-side in a single library together with other library +facilities not covered by this License, and distribute such a combined +library, provided that the separate distribution of the work based on +the Library and of the other library facilities is otherwise +permitted, and provided that you do these two things: + + a) Accompany the combined library with a copy of the same work + based on the Library, uncombined with any other library + facilities. This must be distributed under the terms of the + Sections above. + + b) Give prominent notice with the combined library of the fact + that part of it is a work based on the Library, and explaining + where to find the accompanying uncombined form of the same work. + + 8. You may not copy, modify, sublicense, link with, or distribute +the Library except as expressly provided under this License. Any +attempt otherwise to copy, modify, sublicense, link with, or +distribute the Library is void, and will automatically terminate your +rights under this License. However, parties who have received copies, +or rights, from you under this License will not have their licenses +terminated so long as such parties remain in full compliance. + + 9. You are not required to accept this License, since you have not +signed it. However, nothing else grants you permission to modify or +distribute the Library or its derivative works. These actions are +prohibited by law if you do not accept this License. Therefore, by +modifying or distributing the Library (or any work based on the +Library), you indicate your acceptance of this License to do so, and +all its terms and conditions for copying, distributing or modifying +the Library or works based on it. + + 10. Each time you redistribute the Library (or any work based on the +Library), the recipient automatically receives a license from the +original licensor to copy, distribute, link with or modify the Library +subject to these terms and conditions. You may not impose any further +restrictions on the recipients' exercise of the rights granted herein. +You are not responsible for enforcing compliance by third parties with +this License. + + 11. If, as a consequence of a court judgment or allegation of patent +infringement or for any other reason (not limited to patent issues), +conditions are imposed on you (whether by court order, agreement or +otherwise) that contradict the conditions of this License, they do not +excuse you from the conditions of this License. If you cannot +distribute so as to satisfy simultaneously your obligations under this +License and any other pertinent obligations, then as a consequence you +may not distribute the Library at all. For example, if a patent +license would not permit royalty-free redistribution of the Library by +all those who receive copies directly or indirectly through you, then +the only way you could satisfy both it and this License would be to +refrain entirely from distribution of the Library. + +If any portion of this section is held invalid or unenforceable under any +particular circumstance, the balance of the section is intended to apply, +and the section as a whole is intended to apply in other circumstances. + +It is not the purpose of this section to induce you to infringe any +patents or other property right claims or to contest validity of any +such claims; this section has the sole purpose of protecting the +integrity of the free software distribution system which is +implemented by public license practices. Many people have made +generous contributions to the wide range of software distributed +through that system in reliance on consistent application of that +system; it is up to the author/donor to decide if he or she is willing +to distribute software through any other system and a licensee cannot +impose that choice. + +This section is intended to make thoroughly clear what is believed to +be a consequence of the rest of this License. + + 12. If the distribution and/or use of the Library is restricted in +certain countries either by patents or by copyrighted interfaces, the +original copyright holder who places the Library under this License may add +an explicit geographical distribution limitation excluding those countries, +so that distribution is permitted only in or among countries not thus +excluded. In such case, this License incorporates the limitation as if +written in the body of this License. + + 13. The Free Software Foundation may publish revised and/or new +versions of the Lesser General Public License from time to time. +Such new versions will be similar in spirit to the present version, +but may differ in detail to address new problems or concerns. + +Each version is given a distinguishing version number. If the Library +specifies a version number of this License which applies to it and +"any later version", you have the option of following the terms and +conditions either of that version or of any later version published by +the Free Software Foundation. If the Library does not specify a +license version number, you may choose any version ever published by +the Free Software Foundation. + + 14. If you wish to incorporate parts of the Library into other free +programs whose distribution conditions are incompatible with these, +write to the author to ask for permission. For software which is +copyrighted by the Free Software Foundation, write to the Free +Software Foundation; we sometimes make exceptions for this. Our +decision will be guided by the two goals of preserving the free status +of all derivatives of our free software and of promoting the sharing +and reuse of software generally. + + NO WARRANTY + + 15. BECAUSE THE LIBRARY IS LICENSED FREE OF CHARGE, THERE IS NO +WARRANTY FOR THE LIBRARY, TO THE EXTENT PERMITTED BY APPLICABLE LAW. +EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR +OTHER PARTIES PROVIDE THE LIBRARY "AS IS" WITHOUT WARRANTY OF ANY +KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE +LIBRARY IS WITH YOU. SHOULD THE LIBRARY PROVE DEFECTIVE, YOU ASSUME +THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. + + 16. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN +WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY +AND/OR REDISTRIBUTE THE LIBRARY AS PERMITTED ABOVE, BE LIABLE TO YOU +FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR +CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE +LIBRARY (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING +RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A +FAILURE OF THE LIBRARY TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF +SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH +DAMAGES. + + END OF TERMS AND CONDITIONS + + How to Apply These Terms to Your New Libraries + + If you develop a new library, and you want it to be of the greatest +possible use to the public, we recommend making it free software that +everyone can redistribute and change. You can do so by permitting +redistribution under these terms (or, alternatively, under the terms of the +ordinary General Public License). + + To apply these terms, attach the following notices to the library. It is +safest to attach them to the start of each source file to most effectively +convey the exclusion of warranty; and each file should have at least the +"copyright" line and a pointer to where the full notice is found. + + + Copyright (C) + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Lesser General Public + License as published by the Free Software Foundation; either + version 2.1 of the License, or (at your option) any later version. + + This library is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General Public + License along with this library; if not, write to the Free Software + Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +Also add information on how to contact you by electronic and paper mail. + +You should also get your employer (if you work as a programmer) or your +school, if any, to sign a "copyright disclaimer" for the library, if +necessary. Here is a sample; alter the names: + + Yoyodyne, Inc., hereby disclaims all copyright interest in the + library `Frob' (a library for tweaking knobs) written by James Random Hacker. + + , 1 April 1990 + Ty Coon, President of Vice + +That's all there is to it! diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,3 @@ +#!/usr/bin/env runhaskell +import Distribution.Simple +main = defaultMain diff --git a/haskell-gi.cabal b/haskell-gi.cabal new file mode 100644 --- /dev/null +++ b/haskell-gi.cabal @@ -0,0 +1,88 @@ +name: haskell-gi +version: 0.8 +synopsis: Generate Haskell bindings for GObject Introspection capable libraries +description: Generate Haskell bindings for GObject Introspection capable libraries. This includes most notably + Gtk+, but many other libraries in the GObject ecosystem provide introspection data too. +homepage: https://github.com/haskell-gi/haskell-gi +license: LGPL-2.1 + -- or above +license-file: LICENSE +author: Will Thompson, + Iñaki García Etxebarria, + Jonas Platte +maintainer: Iñaki García Etxebarria (garetxe@gmail.com) +stability: Experimental +category: Development +build-type: Simple +cabal-version: >=1.8 + +source-repository head + type: git + location: git://github.com/haskell-gi/haskell-gi.git + +executable haskell-gi + main-is: haskell-gi.hs + pkgconfig-depends: gobject-introspection-1.0 >= 1.42, gobject-2.0 >= 2.36 + build-depends: base >= 4.7 && < 5, + containers, + directory, + filepath, + file-embed >= 0.0.9, + mtl >= 2.2, + transformers >= 0.3, + pretty-show, + process, + safe, + bytestring, + xdg-basedir, + xml-conduit >= 1.3.0, + haskell-gi-base == 0.8, + text >= 1.0, + free + + build-tools: hsc2hs, c2hs + hs-source-dirs: src + other-modules: GI.GIR.Alias, + GI.GIR.BasicTypes, + GI.GIR.Callback, + GI.GIR.Constant, + GI.GIR.Deprecation, + GI.GIR.Enum, + GI.GIR.Field, + GI.GIR.Flags, + GI.GIR.Method, + GI.GIR.Object, + GI.GIR.Parser, + GI.GIR.Repository, + GI.GIR.Signal, + GI.GIR.Struct, + GI.GIR.Type, + GI.GIR.Union, + GI.GIR.XMLUtils, + GI.API, + GI.Attributes, + GI.Cabal, + GI.Callable, + GI.Code, + GI.Config, + GI.Constant, + GI.Conversions, + GI.GObject, + GI.GType, + GI.Inheritance, + GI.OverloadedSignals, + GI.Overrides, + GI.PkgConfig, + GI.ProjectInfo, + GI.Properties, + GI.LibGIRepository, + GI.Signal, + GI.Struct, + GI.SymbolNaming, + GI.Transfer, + GI.Type, + GI.Util + + extensions: CPP, ForeignFunctionInterface, DoAndIfThenElse, LambdaCase, RankNTypes, OverloadedStrings + ghc-options: -Wall -fno-warn-missing-signatures -fwarn-incomplete-patterns -fno-warn-name-shadowing + c-sources: src/c/enumStorage.c diff --git a/src/GI/API.hs b/src/GI/API.hs new file mode 100644 --- /dev/null +++ b/src/GI/API.hs @@ -0,0 +1,397 @@ +{-# LANGUAGE RecordWildCards, NamedFieldPuns #-} + +module GI.API + ( API(..) + , GIRInfo(..) + , loadGIRInfo + , loadRawGIRInfo + + -- Reexported from GI.GIR.BasicTypes + , Name(..) + , Transfer(..) + + -- Reexported from GI.GIR.Arg + , Direction(..) + , Scope(..) + + -- Reexported from GI.GIR.Deprecation + , deprecatedPragma + , DeprecationInfo + + -- Reexported from GI.GIR.Property + , PropertyFlag(..) + + -- Reexported from GI.GIR.Method + , MethodType(..) + + -- Reexported from the corresponding GI.GIR modules + , Constant(..) + , Arg(..) + , Callable(..) + , Function(..) + , Signal(..) + , Property(..) + , Field(..) + , Struct(..) + , Callback(..) + , Interface(..) + , Method(..) + , Object(..) + , Enumeration(..) + , Flags (..) + , Union (..) + ) where + +import Control.Monad ((>=>), forM, forM_) +import qualified Data.List as L +import qualified Data.Map as M +import Data.Maybe (mapMaybe, catMaybes) +import Data.Monoid ((<>)) +import qualified Data.Set as S +import qualified Data.Text as T +import Data.Text (Text) + +import Foreign.Ptr (Ptr) +import Foreign (peek) +import Foreign.C.Types (CUInt) + +import Text.XML hiding (Name) + +import GI.GIR.Alias (documentListAliases) +import GI.GIR.Arg (Arg(..), Direction(..), Scope(..)) +import GI.GIR.BasicTypes (Alias, Name(..), Transfer(..)) +import GI.GIR.Callable (Callable(..)) +import GI.GIR.Callback (Callback(..), parseCallback) +import GI.GIR.Constant (Constant(..), parseConstant) +import GI.GIR.Deprecation (DeprecationInfo, deprecatedPragma) +import GI.GIR.Enum (Enumeration(..), parseEnum) +import GI.GIR.Field (Field(..)) +import GI.GIR.Flags (Flags(..), parseFlags) +import GI.GIR.Function (Function(..), parseFunction) +import GI.GIR.Interface (Interface(..), parseInterface) +import GI.GIR.Method (Method(..), MethodType(..)) +import GI.GIR.Object (Object(..), parseObject) +import GI.GIR.Parser (Parser, runParser) +import GI.GIR.Property (Property(..), PropertyFlag(..)) +import GI.GIR.Repository (readGiRepository) +import GI.GIR.Signal (Signal(..)) +import GI.GIR.Struct (Struct(..), parseStruct) +import GI.GIR.Union (Union(..), parseUnion) +import GI.GIR.XMLUtils (subelements, childElemsWithLocalName, lookupAttr, + lookupAttrWithNamespace, GIRXMLNamespace(..)) + +import Data.GI.Base.BasicConversions (unpackStorableArrayWithLength) +import Data.GI.Base.BasicTypes (GType(..), CGType, gtypeName) +import Data.GI.Base.Utils (allocMem, freeMem) +import GI.LibGIRepository (girRequire, girStructSizeAndOffsets, + girUnionSizeAndOffsets, girLoadGType) +import GI.GType (gtypeIsBoxed) +import GI.Type (Type) + +data GIRInfo = GIRInfo { + girPCPackages :: [Text], + girNSName :: Text, + girNSVersion :: Text, + girAPIs :: [(Name, API)], + girCTypes :: M.Map Text Name + } deriving Show + +data GIRNamespace = GIRNamespace { + nsName :: Text, + nsVersion :: Text, + nsAPIs :: [(Name, API)], + nsCTypes :: [(Text, Name)] + } deriving (Show) + +data GIRInfoParse = GIRInfoParse { + girIPPackage :: [Maybe Text], + girIPIncludes :: [Maybe (Text, Text)], + girIPNamespaces :: [Maybe GIRNamespace] +} deriving (Show) + +data API + = APIConst Constant + | APIFunction Function + | APICallback Callback + | APIEnum Enumeration + | APIFlags Flags + | APIInterface Interface + | APIObject Object + | APIStruct Struct + | APIUnion Union + deriving Show + +parseAPI :: Text -> M.Map Alias Type -> Element -> (a -> API) + -> Parser (Name, a) -> (Name, API) +parseAPI ns aliases element wrapper parser = + case runParser ns aliases element parser of + Left err -> error $ "Parse error: " ++ T.unpack err + Right (n, a) -> (n, wrapper a) + +parseNSElement :: M.Map Alias Type -> GIRNamespace -> Element -> GIRNamespace +parseNSElement aliases ns@GIRNamespace{..} element + | lookupAttr "introspectable" element == Just "0" = ns + | otherwise = + case nameLocalName (elementName element) of + "alias" -> ns -- Processed separately + "constant" -> parse APIConst parseConstant + "enumeration" -> parse APIEnum parseEnum + "bitfield" -> parse APIFlags parseFlags + "function" -> parse APIFunction parseFunction + "callback" -> parse APICallback parseCallback + "record" -> parse APIStruct parseStruct + "union" -> parse APIUnion parseUnion + "class" -> parse APIObject parseObject + "interface" -> parse APIInterface parseInterface + "boxed" -> ns -- Unsupported + n -> error . T.unpack $ "Unknown GIR element \"" <> n <> "\" when processing namespace \"" <> nsName <> "\", aborting." + where parse :: (a -> API) -> Parser (Name, a) -> GIRNamespace + parse wrapper parser = + let (n, api) = parseAPI nsName aliases element wrapper parser + maybeCType = lookupAttrWithNamespace CGIRNS "type" element + in ns { nsAPIs = (n, api) : nsAPIs, + nsCTypes = case maybeCType of + Just ctype -> (ctype, n) : nsCTypes + Nothing -> nsCTypes + } + +parseNamespace :: Element -> M.Map Alias Type -> Maybe GIRNamespace +parseNamespace element aliases = do + let attrs = elementAttributes element + name <- M.lookup "name" attrs + version <- M.lookup "version" attrs + let ns = GIRNamespace { + nsName = name, + nsVersion = version, + nsAPIs = [], + nsCTypes = [] + } + return (L.foldl' (parseNSElement aliases) ns (subelements element)) + +parseInclude :: Element -> Maybe (Text, Text) +parseInclude element = do + name <- M.lookup "name" attrs + version <- M.lookup "version" attrs + return (name, version) + where attrs = elementAttributes element + +parsePackage :: Element -> Maybe Text +parsePackage element = M.lookup "name" (elementAttributes element) + +parseRootElement :: M.Map Alias Type -> GIRInfoParse -> Element -> GIRInfoParse +parseRootElement aliases info@GIRInfoParse{..} element = + case nameLocalName (elementName element) of + "include" -> info {girIPIncludes = parseInclude element : girIPIncludes} + "package" -> info {girIPPackage = parsePackage element : girIPPackage} + "namespace" -> info {girIPNamespaces = parseNamespace element aliases : girIPNamespaces} + _ -> info + +emptyGIRInfoParse :: GIRInfoParse +emptyGIRInfoParse = GIRInfoParse { + girIPPackage = [], + girIPIncludes = [], + girIPNamespaces = [] + } + +parseGIRDocument :: M.Map Alias Type -> Document -> GIRInfoParse +parseGIRDocument aliases doc = L.foldl' (parseRootElement aliases) emptyGIRInfoParse (subelements (documentRoot doc)) + +-- | Parse the list of includes in a given document. +documentListIncludes :: Document -> S.Set (Text, Text) +documentListIncludes doc = S.fromList (mapMaybe parseInclude includes) + where includes = childElemsWithLocalName "include" (documentRoot doc) + +-- | Load a set of dependencies, recursively. +loadDependencies :: Bool -- Verbose + -> S.Set (Text, Text) -- Requested + -> M.Map (Text, Text) Document -- Loaded so far + -> [FilePath] -- extra path to search + -> IO (M.Map (Text, Text) Document) -- New loaded set +loadDependencies verbose requested loaded extraPaths + | S.null requested = return loaded + | otherwise = do + let (name, version) = S.elemAt 0 requested + doc <- readGiRepository verbose name (Just version) extraPaths + let newLoaded = M.insert (name, version) doc loaded + newRequested = S.union requested (documentListIncludes doc) + notYetLoaded = S.filter (/= (name, version)) newRequested + loadDependencies verbose notYetLoaded newLoaded extraPaths + +-- | Load a given GIR file and recursively its dependencies +loadGIRFile :: Bool -- ^ verbose + -> Text -- ^ name + -> Maybe Text -- ^ version + -> [FilePath] -- ^ extra paths to search + -> IO (Document, -- ^ loaded document + M.Map (Text, Text) Document) -- ^ dependencies +loadGIRFile verbose name version extraPaths = do + doc <- readGiRepository verbose name version extraPaths + deps <- loadDependencies verbose (documentListIncludes doc) M.empty extraPaths + return (doc, deps) + +-- | Turn a GIRInfoParse into a proper GIRInfo, doing some sanity +-- checking along the way. +toGIRInfo :: GIRInfoParse -> Either Text GIRInfo +toGIRInfo info = + case catMaybes (girIPNamespaces info) of + [ns] -> Right GIRInfo { + girPCPackages = (reverse . catMaybes . girIPPackage) info + , girNSName = nsName ns + , girNSVersion = nsVersion ns + , girAPIs = reverse (nsAPIs ns) + , girCTypes = M.fromList (nsCTypes ns) + } + [] -> Left "Found no valid namespace." + _ -> Left "Found multiple namespaces." + +-- | Bare minimum loading and parsing of a single repository, without +-- loading or parsing its dependencies, resolving aliases, or fixing +-- up structs or interfaces. +loadRawGIRInfo :: Bool -- ^ verbose + -> Text -- ^ name + -> Maybe Text -- ^ version + -> [FilePath] -- ^ extra paths to search + -> IO GIRInfo -- ^ bare parsed document +loadRawGIRInfo verbose name version extraPaths = do + doc <- readGiRepository verbose name version extraPaths + case toGIRInfo (parseGIRDocument M.empty doc) of + Left err -> error . T.unpack $ "Error when raw parsing \"" <> name <> "\": " <> err + Right docGIR -> return docGIR + +-- | Load and parse a GIR file, including its dependencies. +loadGIRInfo :: Bool -- ^ verbose + -> Text -- ^ name + -> Maybe Text -- ^ version + -> [FilePath] -- ^ extra paths to search + -> IO (GIRInfo, -- ^ parsed document + [GIRInfo]) -- ^ parsed deps +loadGIRInfo verbose name version extraPaths = do + (doc, deps) <- loadGIRFile verbose name version extraPaths + let aliases = M.unions (map documentListAliases (doc : M.elems deps)) + parsedDoc = toGIRInfo (parseGIRDocument aliases doc) + parsedDeps = map (toGIRInfo . parseGIRDocument aliases) (M.elems deps) + case combineErrors parsedDoc parsedDeps of + Left err -> error . T.unpack $ "Error when parsing \"" <> name <> "\": " <> err + Right (docGIR, depsGIR) -> do + if girNSName docGIR == name + then do + forM_ (docGIR : depsGIR) $ \info -> + girRequire (girNSName info) (girNSVersion info) + (fixedDoc, fixedDeps) <- fixupGIRInfos docGIR depsGIR + return (fixedDoc, fixedDeps) + else error . T.unpack $ "Got unexpected namespace \"" + <> girNSName docGIR <> "\" when parsing \"" <> name <> "\"." + where combineErrors :: Either Text GIRInfo -> [Either Text GIRInfo] + -> Either Text (GIRInfo, [GIRInfo]) + combineErrors parsedDoc parsedDeps = do + doc <- parsedDoc + deps <- sequence parsedDeps + return (doc, deps) + +foreign import ccall "g_type_interface_prerequisites" g_type_interface_prerequisites :: CGType -> Ptr CUInt -> IO (Ptr CGType) + +-- | List the prerequisites for a 'GType' corresponding to an interface. +gtypeInterfaceListPrereqs :: GType -> IO [Text] +gtypeInterfaceListPrereqs (GType cgtype) = do + nprereqsPtr <- allocMem :: IO (Ptr CUInt) + ps <- g_type_interface_prerequisites cgtype nprereqsPtr + nprereqs <- peek nprereqsPtr + psCGTypes <- unpackStorableArrayWithLength nprereqs ps + freeMem ps + freeMem nprereqsPtr + mapM (fmap T.pack . gtypeName . GType) psCGTypes + +-- | The list of prerequisites in GIR files is not always +-- accurate. Instead of relying on this, we instantiate the 'GType' +-- associated to the interface, and listing the interfaces from there. +fixupInterface :: M.Map Text Name -> (Name, API) -> IO (Name, API) +fixupInterface csymbolMap (n@(Name ns _), APIInterface iface) = do + prereqs <- case ifTypeInit iface of + Nothing -> return [] + Just ti -> do + gtype <- girLoadGType (T.pack ns) ti + prereqGTypes <- gtypeInterfaceListPrereqs gtype + forM prereqGTypes $ \p -> do + case M.lookup p csymbolMap of + Just pn -> return pn + Nothing -> error $ "Could not find prerequisite type " ++ show p ++ " for interface " ++ show n + return (n, APIInterface (iface {ifPrerequisites = prereqs})) +fixupInterface _ (n, api) = return (n, api) + +-- | There is not enough info in the GIR files to determine whether a +-- struct is boxed. We find out by instantiating the 'GType' +-- corresponding to the struct (if known) and checking whether it +-- descends from the boxed GType. Similarly, the size of the struct +-- and offset of the fields is hard to compute from the GIR data, we +-- simply reuse the machinery in libgirepository. +fixupStruct :: M.Map Text Name -> (Name, API) -> IO (Name, API) +fixupStruct _ (n, APIStruct s) = do + fixed <- (fixupStructIsBoxed n >=> fixupStructSizeAndOffsets n) s + return (n, APIStruct fixed) +fixupStruct _ api = return api + +-- | Find out whether the struct is boxed. +fixupStructIsBoxed :: Name -> Struct -> IO Struct +-- The type for "GVariant" is marked as "intern", we wrap +-- this one natively. +fixupStructIsBoxed (Name "GLib" "Variant") s = + return (s {structIsBoxed = False}) +fixupStructIsBoxed (Name ns _) s = do + isBoxed <- case structTypeInit s of + Nothing -> return False + Just ti -> do + gtype <- girLoadGType (T.pack ns) ti + return (gtypeIsBoxed gtype) + return (s {structIsBoxed = isBoxed}) + +-- | Fix the size and alignment of fields. This is much easier to do +-- by using libgirepository than reading the GIR file directly. +fixupStructSizeAndOffsets :: Name -> Struct -> IO Struct +fixupStructSizeAndOffsets (Name ns n) s = do + (size, offsetMap) <- girStructSizeAndOffsets (T.pack ns) (T.pack n) + return (s { structSize = size + , structFields = map (fixupField offsetMap) (structFields s)}) + +-- | Same thing for unions. +fixupUnion :: M.Map Text Name -> (Name, API) -> IO (Name, API) +fixupUnion _ (n, APIUnion u) = do + fixed <- (fixupUnionSizeAndOffsets n) u + return (n, APIUnion fixed) +fixupUnion _ api = return api + +-- | Like 'fixupStructSizeAndOffset' above. +fixupUnionSizeAndOffsets :: Name -> Union -> IO Union +fixupUnionSizeAndOffsets (Name ns n) u = do + (size, offsetMap) <- girUnionSizeAndOffsets (T.pack ns) (T.pack n) + return (u { unionSize = size + , unionFields = map (fixupField offsetMap) (unionFields u)}) + +-- | Fixup the offsets of fields using the given offset map. +fixupField :: M.Map Text Int -> Field -> Field +fixupField offsetMap f = + f {fieldOffset = case M.lookup (fieldName f) offsetMap of + Nothing -> error $ "Could not find field " + ++ show (fieldName f) + Just o -> o } + +-- | Fixup parsed GIRInfos: some of the required information is not +-- found in the GIR files themselves, but can be obtained by +-- instantiating the required GTypes from the installed libraries. +fixupGIRInfos :: GIRInfo -> [GIRInfo] -> IO (GIRInfo, [GIRInfo]) +fixupGIRInfos doc deps = (fixup fixupInterface >=> + fixup fixupStruct >=> + fixup fixupUnion) (doc, deps) + where fixup :: (M.Map Text Name -> (Name, API) -> IO (Name, API)) + -> (GIRInfo, [GIRInfo]) -> IO (GIRInfo, [GIRInfo]) + fixup fixer (doc, deps) = do + fixedDoc <- fixAPIs fixer doc + fixedDeps <- mapM (fixAPIs fixer) deps + return (fixedDoc, fixedDeps) + + fixAPIs :: (M.Map Text Name -> (Name, API) -> IO (Name, API)) -> GIRInfo -> IO GIRInfo + fixAPIs fixer info = do + fixedAPIs <- mapM (fixer ctypes) (girAPIs info) + return $ info {girAPIs = fixedAPIs} + + ctypes :: M.Map Text Name + ctypes = M.unions (map girCTypes (doc:deps)) diff --git a/src/GI/Attributes.hs b/src/GI/Attributes.hs new file mode 100644 --- /dev/null +++ b/src/GI/Attributes.hs @@ -0,0 +1,91 @@ +module GI.Attributes + ( genAttributes + , genAllAttributes + ) where + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative ((<$>)) +#endif +import Control.Monad (forM_, when) +import Control.Monad.Writer (tell) +import qualified Data.Set as S +import qualified Data.Text as T +import Data.Text (Text) + +import GI.API +import GI.Code +import GI.SymbolNaming +import GI.Properties +import GI.CodeGen (genPrelude) + +-- A list of distinct property names for all GObjects appearing in the +-- given list of APIs. +findObjectPropNames :: [(Name, API)] -> CodeGen [Text] +findObjectPropNames apis = S.toList <$> go apis S.empty + where + go :: [(Name, API)] -> S.Set Text -> CodeGen (S.Set Text) + go [] set = return set + go ((_, api):apis) set = + case api of + APIInterface iface -> + go apis $ insertProps (ifProperties iface) set + APIObject object -> + go apis $ insertProps (objProperties object) set + _ -> go apis set + + insertProps :: [Property] -> S.Set Text -> S.Set Text + insertProps props set = S.union set ((S.fromList . map propName) props) + +genPropertyAttr :: Text -> CodeGen () +genPropertyAttr pName = group $ do + line $ "-- Property \"" ++ T.unpack pName ++ "\"" + let name = (hyphensToCamelCase . T.unpack) pName + line $ "_" ++ lcFirst name ++ " :: Proxy \"" ++ T.unpack pName ++ "\"" + line $ "_" ++ lcFirst name ++ " = Proxy" + +genAllAttributes :: [(Name, API)] -> String -> CodeGen () +genAllAttributes allAPIs modulePrefix = do + line "-- Generated code." + blank + line "{-# LANGUAGE DataKinds #-}" + blank + + line $ "module " ++ modulePrefix ++ "Properties where" + blank + line $ "import Data.Proxy (Proxy(..))" + blank + + propNames <- findObjectPropNames allAPIs + forM_ propNames $ \name -> do + genPropertyAttr name + blank + +genProps :: (Name, API) -> CodeGen () +genProps (n, APIObject o) = genObjectProperties n o +genProps (n, APIInterface i) = genInterfaceProperties n i +genProps _ = return () + +genAttributes :: String -> [(Name, API)] -> String -> CodeGen () +genAttributes name apis modulePrefix = do + let mp = (modulePrefix ++) + nm = ucFirst name + + code <- recurse' $ forM_ apis genProps + + -- Providing orphan instances is the whole point of these modules, + -- tell GHC that this is fine. + line "{-# OPTIONS_GHC -fno-warn-orphans -fno-warn-unused-imports #-}" + blank + + genPrelude (nm ++ "Attributes") modulePrefix + + deps <- getDeps + forM_ (S.toList deps) $ \i -> when (i /= name) $ do + line $ "import qualified " ++ mp (ucFirst i) ++ " as " ++ ucFirst i + line $ "import qualified " ++ mp (ucFirst i) ++ "Attributes as " + ++ ucFirst i ++ "A" + + line $ "import " ++ modulePrefix ++ nm + blank + + tell code diff --git a/src/GI/Cabal.hs b/src/GI/Cabal.hs new file mode 100644 --- /dev/null +++ b/src/GI/Cabal.hs @@ -0,0 +1,180 @@ +module GI.Cabal + ( genCabalProject + , cabalConfig + , setupHs + ) where + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative ((<$>), (<*>)) +#endif +import Control.Monad (forM_) +import Control.Monad.IO.Class (liftIO) +import Data.List (intercalate) +import Data.Maybe (fromMaybe) +import Data.Monoid ((<>)) +import Data.Version (Version(..), showVersion) +#if MIN_VERSION_base(4,8,0) +import Data.Version (makeVersion) +#endif +import qualified Data.Map as M +import qualified Data.Text as T +import Data.Text (Text) +import Text.Read + +import GI.API (GIRInfo(..)) +import GI.Code +import GI.Config (Config(..)) +import GI.Overrides (pkgConfigMap, cabalPkgVersion) +import GI.PkgConfig (pkgConfigGetVersion) +import GI.ProjectInfo (homepage, license, authors, maintainers) +import GI.Util (padTo) +import GI.SymbolNaming (ucFirst) + +import Paths_haskell_gi (version) + +cabalConfig :: Text +cabalConfig = T.unlines ["documentation: False", + "optimization: False"] + +setupHs :: Text +setupHs = T.unlines ["#!/usr/bin/env runhaskell", + "import Distribution.Simple", + "main = defaultMain"] + +haskellGIAPIVersion :: Int +haskellGIAPIVersion = (head . versionBranch) version + +#if !MIN_VERSION_base(4,8,0) +-- Create a version without tags, which we ignore anyway. The +-- versionTags constructor field is deprecated in base 4.8.0. +makeVersion :: [Int] -> Version +makeVersion branch = Version branch [] +#endif + +haskellGIRevision :: String +haskellGIRevision = + showVersion $ makeVersion (tail (versionBranch version)) + +{- | + +If the haskell-gi version is of the form x.y and the pkgconfig version +of the package being wrapped is a.b.c, this gives something of the +form x.a.b.y. + +This strange seeming-rule is so that the packages that we produce +follow the PVP, assuming that the package being wrapped follows the +usual semantic versioning convention (http://semver.org) that +increases in "a" indicate non-backwards compatible changes, increases +in "b" backwards compatible additions to the API, and increases in "c" +denote API compatible changes (so we do not need to regenerate +bindings for these, at least in principle, so we do not encode them in +the cabal version). + +In order to follow the PVP, then everything we need to do in the +haskell-gi side is to increase x everytime the generated API changes +(for a fixed a.b.c version). + +In any case, if such "strange" package numbers are undesired, or the +wrapped package does not follow semver, it is possible to add an +explicit cabal-pkg-version override. This needs to be maintained by +hand (including in the list of dependencies of packages depending on +this one), so think carefully before using this override! + +-} +giModuleVersion :: Int -> Int -> Text +giModuleVersion major minor = T.pack $ + show haskellGIAPIVersion ++ "." ++ show major ++ "." + ++ show minor ++ "." ++ haskellGIRevision + +-- | Smallest version not backwards compatible with the current +-- version (according to PVP). +nextIncompatibleVersion :: Int -> Text +nextIncompatibleVersion major = T.pack $ + show haskellGIAPIVersion ++ "." ++ show (major+1) + +-- | Determine the pkg-config name and installed version (major.minor +-- only) for a given module, or throw an exception if that fails. +tryPkgConfig :: Text -> Text -> [Text] -> Bool + -> M.Map Text Text + -> ExcCodeGen (Text, Int, Int) +tryPkgConfig name version packages verbose overridenNames = + liftIO (pkgConfigGetVersion name version packages verbose overridenNames) >>= \case + Just (n,v) -> + case readMajorMinor v of + Just (major, minor) -> return (n, major, minor) + Nothing -> notImplementedError . T.unpack $ + "Cannot parse version \"" + <> v <> "\" for module " <> name + Nothing -> missingInfoError . T.unpack $ + "Could not determine the pkg-config name corresponding to \"" <> name <> "\".\n" <> + "Try adding an override with the proper package name:\n" + <> "pkg-config-name " <> name <> " [matching pkg-config name here]" + +-- | Given a string a.b.c..., representing a version number, determine +-- the major and minor versions, i.e. "a" and "b". If successful, +-- return (a,b). +readMajorMinor :: Text -> Maybe (Int, Int) +readMajorMinor version = + case T.splitOn "." version of + (a:b:_) -> (,) <$> readMaybe (T.unpack a) <*> readMaybe (T.unpack b) + _ -> Nothing + +-- | Try to generate the cabal project. In case of error return the +-- corresponding error string. +genCabalProject :: GIRInfo -> [GIRInfo] -> String -> CodeGen (Maybe String) +genCabalProject gir deps modulePrefix = + handleCGExc (return . Just . describeCGError) $ do + cfg <- config + let pkMap = pkgConfigMap (overrides cfg) + name = girNSName gir + pkgVersion = girNSVersion gir + packages = girPCPackages gir + + line $ "-- Autogenerated, do not edit." + line $ padTo 20 "name:" <> "gi-" <> T.unpack (T.toLower name) + (pcName, major, minor) <- tryPkgConfig name pkgVersion packages (verbose cfg) pkMap + let cabalVersion = fromMaybe (giModuleVersion major minor) + (cabalPkgVersion $ overrides cfg) + line $ padTo 20 "version:" ++ T.unpack cabalVersion + line $ padTo 20 "synopsis:" ++ T.unpack name + ++ " bindings" + line $ padTo 20 "description:" ++ "Bindings for " ++ T.unpack name + ++ ", autogenerated by haskell-gi." + line $ padTo 20 "homepage:" ++ homepage + line $ padTo 20 "license:" ++ license + line $ padTo 20 "license-file:" ++ "LICENSE" + line $ padTo 20 "author:" ++ authors + line $ padTo 20 "maintainer:" ++ maintainers + line $ padTo 20 "category:" ++ "Bindings" + line $ padTo 20 "build-type:" ++ "Simple" + line $ padTo 20 "cabal-version:" ++ ">=1.10" + blank + line $ "library" + indent $ do + line $ padTo 20 "default-language:" ++ "Haskell2010" + let base = modulePrefix ++ ucFirst (T.unpack name) + line $ padTo 20 "exposed-modules:" ++ + intercalate ", " [base, base ++ "Attributes", base ++ "Signals"] + line $ padTo 20 "pkgconfig-depends:" ++ T.unpack pcName ++ " >= " + ++ show major ++ "." ++ show minor + line $ padTo 20 "build-depends: base >= 4.6 && <4.9," + indent $ do + line $ "haskell-gi-base >= " ++ showVersion version + ++ " && < " ++ show (haskellGIAPIVersion + 1) ++ "," + forM_ deps $ \dep -> do + let depName = girNSName dep + depVersion = girNSVersion dep + depPackages = girPCPackages dep + (_, depMajor, depMinor) <- tryPkgConfig depName depVersion + depPackages (verbose cfg) pkMap + line . T.unpack $ "gi-" <> T.toLower depName <> " >= " + <> giModuleVersion depMajor depMinor + <> " && < " <> nextIncompatibleVersion depMajor <> "," + -- Our usage of these is very basic, no reason to put any + -- strong upper bounds. + line "bytestring >= 0.10," + line "containers >= 0.5," + line "text >= 1.0," + line "transformers >= 0.3" + + return Nothing -- successful generation, no error diff --git a/src/GI/Callable.hs b/src/GI/Callable.hs new file mode 100644 --- /dev/null +++ b/src/GI/Callable.hs @@ -0,0 +1,697 @@ +{-# LANGUAGE LambdaCase #-} +module GI.Callable + ( genCallable + + , hOutType + , arrayLengths + , arrayLengthsMap + + , wrapMaybe + , inArgInterfaces + ) where + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative ((<$>)) +#endif +import Control.Monad (forM, forM_, when) +import Data.Bool (bool) +import Data.List (intercalate, nub, (\\)) +import Data.Maybe (isJust) +import Data.Typeable (TypeRep, tyConName, typeRepTyCon, typeOf) +import qualified Data.Map as Map +import qualified Data.Text as T +import Data.Text (Text) + +import GI.API +import GI.Code +import GI.Conversions +import GI.SymbolNaming +import GI.Transfer +import GI.Type +import GI.Util + +import Text.Show.Pretty (ppShow) + +hOutType :: Callable -> [Arg] -> Bool -> ExcCodeGen TypeRep +hOutType callable outArgs ignoreReturn = do + hReturnType <- case returnType callable of + TBasicType TVoid -> return $ typeOf () + _ -> if ignoreReturn + then return $ typeOf () + else haskellType $ returnType callable + hOutArgTypes <- forM outArgs $ \outarg -> + wrapMaybe outarg >>= bool + (haskellType (argType outarg)) + (maybeT <$> haskellType (argType outarg)) + let maybeHReturnType = if returnMayBeNull callable && not ignoreReturn + then maybeT hReturnType + else hReturnType + return $ case (outArgs, show maybeHReturnType) of + ([], _) -> maybeHReturnType + (_, "()") -> "(,)" `con` hOutArgTypes + _ -> "(,)" `con` (maybeHReturnType : hOutArgTypes) + +mkForeignImport :: Text -> Callable -> Bool -> CodeGen () +mkForeignImport symbol callable throwsGError = foreignImport $ do + line first + indent $ do + mapM_ (\a -> line =<< fArgStr a) (args callable) + when throwsGError $ + line $ padTo 40 "Ptr (Ptr GError) -> " ++ "-- error" + line =<< last + where + first = "foreign import ccall \"" ++ T.unpack symbol ++ "\" " ++ + T.unpack symbol ++ " :: " + fArgStr arg = do + ft <- foreignType $ argType arg + weAlloc <- isJust <$> requiresAlloc (argType arg) + let ft' = if direction arg == DirectionIn || weAlloc then + ft + else + ptr ft + let start = show ft' ++ " -> " + return $ padTo 40 start ++ "-- " ++ T.unpack (argName arg) + ++ " : " ++ show (argType arg) + last = show <$> io <$> case returnType callable of + TBasicType TVoid -> return $ typeOf () + _ -> foreignType (returnType callable) + +-- Given an argument to a function, return whether it should be +-- wrapped in a maybe type (useful for nullable types). We do some +-- sanity checking to make sure that the argument is actually nullable +-- (a relatively common annotation mistake is to mix up (optional) +-- with (nullable)). +wrapMaybe :: Arg -> ExcCodeGen Bool +wrapMaybe arg = + if mayBeNull arg + then case argType arg of + -- NULL GLists and GSLists are semantically the same as an + -- empty list, so they don't need a Maybe wrapper on their + -- type. + TGList _ -> return False + TGSList _ -> return False + _ -> if isNullable (argType arg) + then return True + else badIntroError $ "argument \"" ++ T.unpack (argName arg) ++ "\" is not of nullable type, but it is marked as such." + else return False + +-- Given the list of arguments returns the list of constraints and the +-- list of types in the signature. +inArgInterfaces :: [Arg] -> ExcCodeGen ([String], [String]) +inArgInterfaces inArgs = consAndTypes (['a'..'z'] \\ ['m']) inArgs + where + consAndTypes :: [Char] -> [Arg] -> ExcCodeGen ([String], [String]) + consAndTypes _ [] = return ([], []) + consAndTypes letters (arg:args) = do + (ls, t, cons) <- argumentType letters $ argType arg + t' <- wrapMaybe arg >>= bool (return t) + (return $ "Maybe (" ++ t ++ ")") + (restCons, restTypes) <- consAndTypes ls args + return (cons ++ restCons, t' : restTypes) + +-- Given a callable, return a list of (array, length) pairs, where in +-- each pair "length" is the argument holding the length of the +-- (non-zero-terminated, non-fixed size) C array. +arrayLengthsMap :: Callable -> [(Arg, Arg)] -- List of (array, length) +arrayLengthsMap callable = go (args callable) [] + where + go :: [Arg] -> [(Arg, Arg)] -> [(Arg, Arg)] + go [] acc = acc + go (a:as) acc = case argType a of + TCArray False fixedSize length _ -> + if fixedSize > -1 || length == -1 + then go as acc + else go as $ (a, (args callable)!!length) : acc + _ -> go as acc + +-- Return the list of arguments of the callable that contain length +-- arguments, including a possible length for the result of calling +-- the function. +arrayLengths :: Callable -> [Arg] +arrayLengths callable = map snd (arrayLengthsMap callable) ++ + -- Often one of the arguments is just the length of + -- the result. + case returnType callable of + TCArray False (-1) length _ -> + if length > -1 + then [(args callable)!!length] + else [] + _ -> [] + +-- This goes through a list of [(a,b)], and tags every entry where the +-- "b" field has occurred before with the value of "a" for which it +-- occurred. (The first appearance is not tagged.) +classifyDuplicates :: Ord b => [(a, b)] -> [(a, b, Maybe a)] +classifyDuplicates args = doClassify Map.empty args + where doClassify :: Ord b => Map.Map b a -> [(a, b)] -> [(a, b, Maybe a)] + doClassify _ [] = [] + doClassify found ((value, key):args) = + (value, key, Map.lookup key found) : + doClassify (Map.insert key value found) args + +-- Read the length of in array arguments from the corresponding +-- Haskell objects. A subtlety is that sometimes a single length +-- argument is expected from the C side to encode the length of +-- various lists. Ideally we would encode this in the types, but the +-- resulting API would be rather cumbersome. We insted perform runtime +-- checks to make sure that the given lists have the same length. +readInArrayLengths :: Name -> Callable -> [Arg] -> ExcCodeGen () +readInArrayLengths name callable hInArgs = do + let lengthMaps = classifyDuplicates $ arrayLengthsMap callable + forM_ lengthMaps $ \(array, length, duplicate) -> + when (array `elem` hInArgs) $ + case duplicate of + Nothing -> readInArrayLength array length + Just previous -> checkInArrayLength name array length previous + +-- Read the length of an array into the corresponding variable. +readInArrayLength :: Arg -> Arg -> ExcCodeGen () +readInArrayLength array length = do + let lvar = escapeReserved $ argName length + avar = escapeReserved $ argName array + wrapMaybe array >>= bool + (do + al <- computeArrayLength avar (argType array) + line $ "let " ++ lvar ++ " = " ++ al) + (do + line $ "let " ++ lvar ++ " = case " ++ avar ++ " of" + indent $ indent $ do + line $ "Nothing -> 0" + let jarray = "j" ++ ucFirst avar + al <- computeArrayLength jarray (argType array) + line $ "Just " ++ jarray ++ " -> " ++ al) + +-- Check that the given array has a length equal to the given length +-- variable. +checkInArrayLength :: Name -> Arg -> Arg -> Arg -> ExcCodeGen () +checkInArrayLength n array length previous = do + name <- lowerName n + let funcName = namespace n ++ "." ++ name + lvar = escapeReserved $ argName length + avar = escapeReserved $ argName array + expectedLength = avar ++ "_expected_length_" + pvar = escapeReserved $ argName previous + wrapMaybe array >>= bool + (do + al <- computeArrayLength avar (argType array) + line $ "let " ++ expectedLength ++ " = " ++ al) + (do + line $ "let " ++ expectedLength ++ " = case " ++ avar ++ " of" + indent $ indent $ do + line $ "Nothing -> 0" + let jarray = "j" ++ ucFirst avar + al <- computeArrayLength jarray (argType array) + line $ "Just " ++ jarray ++ " -> " ++ al) + line $ "when (" ++ expectedLength ++ " /= " ++ lvar ++ ") $" + indent $ line $ "error \"" ++ funcName ++ " : length of '" ++ avar ++ + "' does not agree with that of '" ++ pvar ++ "'.\"" + +-- Whether to skip the return value in the generated bindings. The +-- C convention is that functions throwing an error and returning +-- a gboolean set the boolean to TRUE iff there is no error, so +-- the information is always implicit in whether we emit an +-- exception or not, so the return value can be omitted from the +-- generated bindings without loss of information (and omitting it +-- gives rise to a nicer API). See +-- https://bugzilla.gnome.org/show_bug.cgi?id=649657 +skipRetVal :: Callable -> Bool -> Bool +skipRetVal callable throwsGError = + (skipReturn callable) || + (throwsGError && returnType callable == TBasicType TBoolean) + +freeInArgs' :: (Arg -> String -> String -> ExcCodeGen [String]) -> + Callable -> Map.Map String String -> ExcCodeGen [String] +freeInArgs' freeFn callable nameMap = concat <$> actions + where + actions :: ExcCodeGen [[String]] + actions = forM (args callable) $ \arg -> + case Map.lookup (escapeReserved $ argName arg) nameMap of + Just name -> freeFn arg name $ + -- Pass in the length argument in case it's needed. + case argType arg of + TCArray False (-1) (-1) _ -> undefined + TCArray False (-1) length _ -> + escapeReserved $ argName $ (args callable)!!length + _ -> undefined + Nothing -> badIntroError $ "freeInArgs: do not understand " ++ show arg + +-- Return the list of actions freeing the memory associated with the +-- callable variables. This is run if the call to the C function +-- succeeds, if there is an error freeInArgsOnError below is called +-- instead. +freeInArgs = freeInArgs' freeInArg + +-- Return the list of actions freeing the memory associated with the +-- callable variables. This is run in case there is an error during +-- the call. +freeInArgsOnError = freeInArgs' freeInArgOnError + +-- Marshall the haskell arguments into their corresponding C +-- equivalents. omitted gives a list of DirectionIn arguments that +-- should be ignored, as they will be dealt with separately. +prepareArgForCall :: [Arg] -> Arg -> ExcCodeGen String +prepareArgForCall omitted arg = do + isCallback <- findAPI (argType arg) >>= + \case Just (APICallback _) -> return True + _ -> return False + when (isCallback && direction arg /= DirectionIn) $ + notImplementedError "Only callbacks with DirectionIn are supported" + + case direction arg of + DirectionIn -> if arg `elem` omitted + then return . escapeReserved . argName $ arg + else if isCallback + then prepareInCallback arg + else prepareInArg arg + DirectionInout -> prepareInoutArg arg + DirectionOut -> prepareOutArg arg + +prepareInArg :: Arg -> ExcCodeGen String +prepareInArg arg = do + let name = escapeReserved $ argName arg + wrapMaybe arg >>= bool + (convert name $ hToF (argType arg) (transfer arg)) + (do + let maybeName = "maybe" ++ ucFirst name + line $ maybeName ++ " <- case " ++ name ++ " of" + indent $ do + line $ "Nothing -> return nullPtr" + let jName = "j" ++ ucFirst name + line $ "Just " ++ jName ++ " -> do" + indent $ do + converted <- convert jName $ hToF (argType arg) + (transfer arg) + line $ "return " ++ converted + return maybeName) + +-- Callbacks are a fairly special case, we treat them separately. +prepareInCallback :: Arg -> ExcCodeGen String +prepareInCallback arg = do + let name = escapeReserved $ argName arg + ptrName = "ptr" ++ name + scope = argScope arg + + (maker, wrapper) <- case argType arg of + (TInterface ns n) -> + do + prefix <- qualify ns + return $ (prefix ++ "mk" ++ n, + prefix ++ lcFirst n ++ "Wrapper") + _ -> error $ "prepareInCallback : Not an interface! " ++ ppShow arg + + fC <- tyConName <$> typeRepTyCon <$> foreignType (argType arg) + + when (scope == ScopeTypeAsync) $ + line $ ptrName ++ " <- callocBytes $ sizeOf (undefined :: " ++ fC ++ ")" + wrapMaybe arg >>= bool + (do + let name' = prime name + p = if (scope == ScopeTypeAsync) + then parenthesize $ "Just " ++ ptrName + else "Nothing" + line $ name' ++ " <- " ++ maker ++ " " + ++ parenthesize (wrapper ++ " " ++ p ++ " " ++ name) + when (scope == ScopeTypeAsync) $ + line $ "poke " ++ ptrName ++ " " ++ name' + return name') + (do + let maybeName = "maybe" ++ ucFirst name + line $ maybeName ++ " <- case " ++ name ++ " of" + indent $ do + line $ "Nothing -> return (castPtrToFunPtr nullPtr)" + let jName = "j" ++ ucFirst name + jName' = prime jName + line $ "Just " ++ jName ++ " -> do" + indent $ do + let p = if (scope == ScopeTypeAsync) + then parenthesize $ "Just " ++ ptrName + else "Nothing" + line $ jName' ++ " <- " ++ maker ++ " " + ++ parenthesize (wrapper ++ " " + ++ p ++ " " ++ jName) + when (scope == ScopeTypeAsync) $ + line $ "poke " ++ ptrName ++ " " ++ jName' + line $ "return " ++ jName' + return maybeName) + +prepareInoutArg :: Arg -> ExcCodeGen String +prepareInoutArg arg = do + name' <- prepareInArg arg + ft <- foreignType $ argType arg + allocInfo <- requiresAlloc (argType arg) + case allocInfo of + Just (isBoxed, n) -> do + let allocator = if isBoxed + then "callocBoxedBytes" + else "callocBytes" + wrapMaybe arg >>= bool + (do + name'' <- genConversion (prime name') $ + literal $ M $ allocator ++ " " ++ show n ++ + " :: " ++ show (io ft) + line $ "memcpy " ++ name'' ++ " " ++ name' ++ " " ++ show n + return name'') + -- The semantics of this case are somewhat undefined. + (notImplementedError "Nullable inout structs not supported") + Nothing -> do + name'' <- genConversion (prime name') $ + literal $ M $ "allocMem :: " ++ show (io $ ptr ft) + line $ "poke " ++ name'' ++ " " ++ name' + return name'' + +prepareOutArg :: Arg -> CodeGen String +prepareOutArg arg = do + let name = escapeReserved $ argName arg + ft <- foreignType $ argType arg + allocInfo <- requiresAlloc (argType arg) + case allocInfo of + Just (isBoxed, n) -> do + let allocator = if isBoxed + then "callocBoxedBytes" + else "callocBytes" + genConversion name $ literal $ M $ allocator ++ " " ++ show n ++ + " :: " ++ show (io ft) + Nothing -> + genConversion name $ + literal $ M $ "allocMem :: " ++ show (io $ ptr ft) + +-- Convert a non-zero terminated out array, stored in a variable +-- named "aname", into the corresponding Haskell object. +convertOutCArray :: Callable -> Type -> String -> Map.Map String String -> + Transfer -> ExcCodeGen String +convertOutCArray callable t@(TCArray False fixed length _) aname + nameMap transfer = do + if fixed > -1 + then do + unpacked <- convert aname $ unpackCArray (show fixed) t transfer + -- Free the memory associated with the array + freeContainerType transfer t aname undefined + return unpacked + else do + when (length == -1) $ + badIntroError $ "Unknown length for \"" ++ aname ++ "\"" + let lname = escapeReserved $ argName $ (args callable)!!length + lname' <- case Map.lookup lname nameMap of + Just n -> return n + Nothing -> + badIntroError $ "Couldn't find out array length " ++ + lname + let lname'' = prime lname' + unpacked <- convert aname $ unpackCArray lname'' t transfer + -- Free the memory associated with the array + freeContainerType transfer t aname lname'' + return unpacked + +-- Remove the warning, this should never be reached. +convertOutCArray _ t _ _ _ = + error $ "convertOutCArray : unexpected " ++ show t + +-- Read the array lengths for out arguments. +readOutArrayLengths :: Callable -> Map.Map String String -> ExcCodeGen () +readOutArrayLengths callable nameMap = do + let lNames = nub $ map (escapeReserved . argName) $ + filter ((/= DirectionIn) . direction) $ + arrayLengths callable + forM_ lNames $ \lname -> do + lname' <- case Map.lookup lname nameMap of + Just n -> return n + Nothing -> + badIntroError $ "Couldn't find out array length " ++ + lname + genConversion lname' $ apply $ M "peek" + +-- Touch DirectionIn arguments so we are sure that they exist when the +-- C function was called. +touchInArg :: Arg -> ExcCodeGen () +touchInArg arg = when (direction arg /= DirectionOut) $ do + let name = escapeReserved $ argName arg + case elementType (argType arg) of + Just a -> do + managed <- isManaged a + when managed $ wrapMaybe arg >>= bool + (line $ "mapM_ touchManagedPtr " ++ name) + (line $ "whenJust " ++ name ++ " (mapM_ touchManagedPtr)") + Nothing -> do + managed <- isManaged (argType arg) + when managed $ wrapMaybe arg >>= bool + (line $ "touchManagedPtr " ++ name) + (line $ "whenJust " ++ name ++ " touchManagedPtr") + +-- Find the association between closure arguments and their +-- corresponding callback. +closureToCallbackMap :: Callable -> ExcCodeGen (Map.Map Int Arg) +closureToCallbackMap callable = + -- The introspection info does not specify the closure for destroy + -- notify's associated with a callback, since it is implicitly the + -- same one as the ScopeTypeNotify callback associated with the + -- DestroyNotify. + go (filter (not . (`elem` destroyers)) $ args callable) Map.empty + + where destroyers = map (args callable!!) . filter (/= -1) . map argDestroy + $ args callable + + go :: [Arg] -> Map.Map Int Arg -> ExcCodeGen (Map.Map Int Arg) + go [] m = return m + go (arg:as) m = + if argScope arg == ScopeTypeInvalid + then go as m + else case argClosure arg of + (-1) -> go as m + c -> case Map.lookup c m of + Just _ -> notImplementedError $ + "Closure for multiple callbacks unsupported" + ++ ppShow arg ++ "\n" + ++ ppShow callable + Nothing -> go as $ Map.insert c arg m + +-- user_data style arguments. +prepareClosures :: Callable -> Map.Map String String -> ExcCodeGen () +prepareClosures callable nameMap = do + m <- closureToCallbackMap callable + let closures = filter (/= -1) . map argClosure $ args callable + forM_ closures $ \closure -> + case Map.lookup closure m of + Nothing -> badIntroError $ "Closure not found! " + ++ ppShow callable + ++ "\n" ++ ppShow m + ++ "\n" ++ show closure + Just cb -> do + let closureName = escapeReserved $ argName $ (args callable)!!closure + n = escapeReserved $ argName cb + n' <- case Map.lookup n nameMap of + Just n -> return n + Nothing -> badIntroError $ "Cannot find closure name!! " + ++ ppShow callable ++ "\n" + ++ ppShow nameMap + case argScope cb of + ScopeTypeInvalid -> badIntroError $ "Invalid scope! " + ++ ppShow callable + ScopeTypeNotified -> do + line $ "let " ++ closureName ++ " = castFunPtrToPtr " ++ n' + case argDestroy cb of + (-1) -> badIntroError $ + "ScopeTypeNotified without destructor! " + ++ ppShow callable + k -> let destroyName = + escapeReserved . argName $ (args callable)!!k in + line $ "let " ++ destroyName ++ " = safeFreeFunPtrPtr" + ScopeTypeAsync -> + line $ "let " ++ closureName ++ " = nullPtr" + ScopeTypeCall -> line $ "let " ++ closureName ++ " = nullPtr" + +freeCallCallbacks :: Callable -> Map.Map String String -> ExcCodeGen () +freeCallCallbacks callable nameMap = + forM_ (args callable) $ \arg -> do + let name = escapeReserved $ argName arg + name' <- case Map.lookup name nameMap of + Just n -> return n + Nothing -> badIntroError $ "Could not find " ++ name + ++ " in " ++ ppShow callable ++ "\n" + ++ ppShow nameMap + when (argScope arg == ScopeTypeCall) $ + line $ "safeFreeFunPtr $ castFunPtrToPtr " ++ name' + +hSignature :: [Arg] -> TypeRep -> ExcCodeGen () +hSignature hInArgs retType = do + (argConstraints, types) <- inArgInterfaces hInArgs + indent $ do + line $ "(" ++ intercalate ", " ("MonadIO m" : argConstraints) ++ ") =>" + forM_ (zip types hInArgs) $ \(t, a) -> + line $ withComment (t ++ " ->") $ T.unpack (argName a) + line . show $ "m" `con` [retType] + +genCallable :: Name -> Text -> Callable -> Bool -> ExcCodeGen () +genCallable n symbol callable throwsGError = do + group $ do + line $ "-- Args : " ++ (show $ args callable) + line $ "-- Lengths : " ++ (show $ arrayLengths callable) + line $ "-- hInArgs : " ++ show hInArgs + line $ "-- returnType : " ++ (show $ returnType callable) + line $ "-- throws : " ++ (show throwsGError) + line $ "-- Skip return : " ++ (show $ skipReturn callable) + when (skipReturn callable && returnType callable /= TBasicType TBoolean) $ + do line "-- XXX return value ignored, but it is not a boolean." + line "-- This may be a memory leak?" + mkForeignImport symbol callable throwsGError + blank + wrapper + + where + inArgs = filter ((/= DirectionOut) . direction) $ args callable + -- We do not expose user_data arguments, destroynotify arguments, + -- and C array length arguments to Haskell code. + closures = map (args callable!!) . filter (/= -1) . map argClosure $ inArgs + destroyers = map (args callable!!) . filter (/= -1) . map argDestroy $ inArgs + omitted = arrayLengths callable ++ closures ++ destroyers + hInArgs = filter (`notElem` omitted) inArgs + outArgs = filter ((/= DirectionIn) . direction) $ args callable + hOutArgs = filter (`notElem` (arrayLengths callable)) outArgs + + ignoreReturn = skipRetVal callable throwsGError + + wrapper = group $ do + let argName' = escapeReserved . argName + name <- lowerName n + line $ deprecatedPragma name $ callableDeprecated callable + line $ name ++ " ::" + hSignature hInArgs =<< hOutType callable hOutArgs ignoreReturn + line $ name ++ " " ++ intercalate " " (map argName' hInArgs) ++ " = liftIO $ do" + indent $ do + readInArrayLengths n callable hInArgs + inArgNames <- forM (args callable) $ \arg -> + prepareArgForCall omitted arg + -- Map from argument names to names passed to the C function + let nameMap = Map.fromList $ flip zip inArgNames + $ map argName' $ args callable + prepareClosures callable nameMap + if throwsGError + then do + line "onException (do" + indent $ do + invokeCFunction inArgNames + readOutArrayLengths callable nameMap + result <- convertResult nameMap + pps <- convertOut nameMap + freeCallCallbacks callable nameMap + forM_ (args callable) touchInArg + mapM_ line =<< freeInArgs callable nameMap + returnResult result pps + line " ) (do" + indent $ do + freeCallCallbacks callable nameMap + actions <- freeInArgsOnError callable nameMap + case actions of + [] -> line $ "return ()" + _ -> mapM_ line actions + line " )" + else do + invokeCFunction inArgNames + readOutArrayLengths callable nameMap + result <- convertResult nameMap + pps <- convertOut nameMap + freeCallCallbacks callable nameMap + forM_ (args callable) touchInArg + mapM_ line =<< freeInArgs callable nameMap + returnResult result pps + + invokeCFunction argNames = do + let returnBind = case returnType callable of + TBasicType TVoid -> "" + _ -> if ignoreReturn + then "_ <- " + else "result <- " + maybeCatchGErrors = if throwsGError + then "propagateGError $ " + else "" + line $ returnBind ++ maybeCatchGErrors + ++ T.unpack symbol ++ concatMap (" " ++) argNames + + convertResult :: Map.Map String String -> ExcCodeGen String + convertResult nameMap = + if ignoreReturn || returnType callable == TBasicType TVoid + then return undefined + else do + if returnMayBeNull callable + then do + line $ "maybeResult <- convertIfNonNull result $ \\result' -> do" + indent $ do + converted <- unwrappedConvertResult "result'" + line $ "return " ++ converted + return "maybeResult" + else unwrappedConvertResult "result" + + where + unwrappedConvertResult rname = case returnType callable of + -- Arrays without length information are just passed + -- along. + TCArray False (-1) (-1) _ -> return rname + -- Not zero-terminated C arrays require knowledge of the + -- length, so we deal with them directly. + t@(TCArray False _ _ _) -> + convertOutCArray callable t rname nameMap + (returnTransfer callable) + t -> do + result <- convert rname $ fToH (returnType callable) + (returnTransfer callable) + freeContainerType (returnTransfer callable) t rname undefined + return result + + convertOut :: Map.Map String String -> ExcCodeGen [String] + convertOut nameMap = do + -- Convert out parameters and result + forM hOutArgs $ \arg -> do + let name = escapeReserved $ argName arg + inName <- case Map.lookup name nameMap of + Just name' -> return name' + Nothing -> badIntroError $ "Parameter " ++ name ++ " not found!" + case argType arg of + -- Passed along as a raw pointer + TCArray False (-1) (-1) _ -> genConversion inName $ apply $ M "peek" + t@(TCArray False _ _ _) -> do + aname' <- genConversion inName $ apply $ M "peek" + let wrapArray a = convertOutCArray callable t a + nameMap (transfer arg) + wrapMaybe arg >>= bool + (wrapArray aname') + (do line $ "maybe" ++ ucFirst aname' + ++ " <- convertIfNonNull " ++ aname' + ++ " $ \\" ++ prime aname' ++ " -> do" + indent $ do + wrapped <- wrapArray (prime aname') + line $ "return " ++ wrapped + return $ "maybe" ++ ucFirst aname') + t -> do + weAlloc <- isJust <$> requiresAlloc t + peeked <- if weAlloc + then return inName + else genConversion inName $ apply $ M "peek" + -- If we alloc we always take control of the resulting + -- memory, otherwise we may leak. + let transfer' = if weAlloc + then TransferEverything + else transfer arg + result <- do + let wrap ptr = convert ptr $ fToH (argType arg) transfer' + wrapMaybe arg >>= bool + (wrap peeked) + (do line $ "maybe" ++ ucFirst peeked + ++ " <- convertIfNonNull " ++ peeked + ++ " $ \\" ++ prime peeked ++ " -> do" + indent $ do + wrapped <- wrap (prime peeked) + line $ "return " ++ wrapped + return $ "maybe" ++ ucFirst peeked) + -- Free the memory associated with the out argument + freeContainerType transfer' t peeked undefined + return result + + returnResult :: String -> [String] -> CodeGen () + returnResult result pps = + if ignoreReturn || returnType callable == TBasicType TVoid + then case pps of + [] -> line "return ()" + (pp:[]) -> line $ "return " ++ pp + _ -> line $ "return (" ++ intercalate ", " pps ++ ")" + else case pps of + [] -> line $ "return " ++ result + _ -> line $ "return (" ++ intercalate ", " (result : pps) ++ ")" diff --git a/src/GI/Code.hs b/src/GI/Code.hs new file mode 100644 --- /dev/null +++ b/src/GI/Code.hs @@ -0,0 +1,249 @@ +module GI.Code + ( Code(..) + , BaseCodeGen + , CodeGen + , ExcCodeGen + , CGError(..) + , genCode + , evalCodeGen + , codeToString + , loadDependency + , getDeps + , recurse + , recurse' + , handleCGExc + , describeCGError + , notImplementedError + , badIntroError + , missingInfoError + , indent + , line + , blank + , group + , foreignImport + + , findAPI + , findAPIByName + , getAPIs + , injectAPIs + + , config + ) where + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative ((<$>)) +#endif +import Control.Monad.RWS +import Control.Monad.Except +import Data.Sequence (Seq, ViewL ((:<)), (><), (|>), (<|)) +import qualified Data.Map as M +import qualified Data.Sequence as S +import qualified Data.Set as Set + +import GI.API (API, Name(..)) +import GI.Config (Config(..)) +import GI.Type (Type(..)) + +data Code + = NoCode + | Line String + | Indent Code + | Sequence (Seq Code) + | ForeignImport Code + | Group Code + deriving (Eq, Show) + +instance Monoid Code where + mempty = NoCode + + NoCode `mappend` NoCode = NoCode + x `mappend` NoCode = x + NoCode `mappend` x = x + (Sequence a) `mappend` (Sequence b) = Sequence (a >< b) + (Sequence a) `mappend` b = Sequence (a |> b) + a `mappend` (Sequence b) = Sequence (a <| b) + a `mappend` b = Sequence (a <| b <| S.empty) + +type Deps = Set.Set String +data CodeGenState = CodeGenState { + moduleDeps :: Deps, + loadedAPIs :: M.Map Name API } + +data CGError = CGErrorNotImplemented String + | CGErrorBadIntrospectionInfo String + | CGErrorMissingInfo String + deriving (Show) + +type BaseCodeGen excType a = + RWST Config Code CodeGenState (ExceptT excType IO) a + +-- | The code generator monad, for generators that cannot throw +-- errors. The fact that they cannot throw errors is encoded in the +-- forall, which disallows any operation on the error, except +-- discarding it or passing it along without inspecting. This last +-- operation is useful in order to allow embedding `CodeGen` +-- computations inside `ExcCodeGen` computations, while disallowing +-- the opposite embedding without explicit error handling. +type CodeGen a = forall e. BaseCodeGen e a + +-- | Code generators that can throw errors. +type ExcCodeGen a = BaseCodeGen CGError a + +-- | Due to the `forall` in the definition of `CodeGen`, if we want to +-- run the monad transformer stack until we get an `IO` action, our +-- only option is ignoring the possible error code from +-- `runExceptT`. This is perfectly safe, since there is no way to +-- construct a computation in the `CodeGen` monad that throws an +-- exception, due to the higher rank type. +unwrapCodeGen :: Config -> CodeGenState -> CodeGen a -> + IO (a, CodeGenState, Code) +unwrapCodeGen cfg state cg = + runExceptT (runRWST cg cfg state) >>= \case + Left _ -> error "unwrapCodeGen:: The impossible happened!" + Right (r, s, c) -> return (r, s, c) + +-- | Run the given code generator, merging its resulting state into +-- the ambient state, and turning its output into a value. +recurse :: BaseCodeGen e a -> BaseCodeGen e (a, Code) +recurse cg = do + r <- ask + oldState <- get + liftIO (runExceptT $ runRWST cg r oldState) >>= \case + Left e -> throwError e + Right (r, st, c) -> put (mergeState oldState st) >> return (r, c) + +-- | Try running the given `action`, and if it fails run `fallback` +-- instead. +handleCGExc :: (CGError -> CodeGen a) -> ExcCodeGen a -> CodeGen a +handleCGExc fallback action = do + r <- ask + oldState <- get + liftIO (runExceptT $ runRWST action r oldState) >>= \case + Left e -> fallback e + Right (r, s, c) -> do + put $ mergeState oldState s + tell c + return r + +emptyState :: CodeGenState +emptyState = CodeGenState {moduleDeps = Set.empty + ,loadedAPIs = M.empty } + +getDeps :: CodeGen Deps +getDeps = moduleDeps <$> get + +getAPIs :: CodeGen (M.Map Name API) +getAPIs = loadedAPIs <$> get + +-- | Inject the given APIs into loaded set. +injectAPIs :: [(Name, API)] -> CodeGen() +injectAPIs newAPIs = do + oldState <- get + put $ oldState {loadedAPIs = + M.union (loadedAPIs oldState) (M.fromList newAPIs)} + +-- | Merge two states of a code generator. +mergeState :: CodeGenState -> CodeGenState -> CodeGenState +mergeState oldState newState = + -- If no dependencies were added we do not need to merge. + if Set.size (moduleDeps oldState) /= Set.size (moduleDeps newState) + then let newDeps = Set.union (moduleDeps oldState) (moduleDeps newState) + newAPIs = M.union (loadedAPIs oldState) (loadedAPIs newState) + in CodeGenState {moduleDeps = newDeps, loadedAPIs = newAPIs} + else oldState + +-- | Run a code generator, and return the dependencies encountered +-- when generating code. +genCode :: Config -> M.Map Name API -> CodeGen () -> IO (Deps, Code) +genCode cfg apis cg = do + (_, st, code) <- unwrapCodeGen cfg (emptyState {loadedAPIs = apis}) cg + return (moduleDeps st, code) + +-- | Like `genCode`, but keep the final value and output, discarding +-- the state. +evalCodeGen :: Config -> M.Map Name API -> CodeGen a -> IO (a, Code) +evalCodeGen cfg apis cg = do + (r, _, code) <- unwrapCodeGen cfg (emptyState {loadedAPIs = apis}) cg + return (r, code) + +-- | Like `recurse`, but for generators returning a unit value, where +-- we can just drop the result. +recurse' :: CodeGen () -> CodeGen Code +recurse' cg = snd <$> recurse cg + +-- | Mark the given dependency as used by the module. +loadDependency :: String -> CodeGen () +loadDependency name = do + deps <- getDeps + unless (Set.member name deps) $ do + let newDeps = Set.insert name deps + modify' $ \s -> s {moduleDeps = newDeps} + +-- | Give a friendly textual description of the error for presenting +-- to the user. +describeCGError :: CGError -> String +describeCGError (CGErrorNotImplemented e) = "Not implemented: " ++ show e +describeCGError (CGErrorBadIntrospectionInfo e) = "Bad introspection data: " ++ show e +describeCGError (CGErrorMissingInfo e) = "Missing info: " ++ show e + +notImplementedError :: String -> ExcCodeGen a +notImplementedError s = throwError $ CGErrorNotImplemented s + +badIntroError :: String -> ExcCodeGen a +badIntroError s = throwError $ CGErrorBadIntrospectionInfo s + +missingInfoError :: String -> ExcCodeGen a +missingInfoError s = throwError $ CGErrorMissingInfo s + +findAPI :: Type -> CodeGen (Maybe API) +findAPI TError = Just <$> findAPIByName (Name "GLib" "Error") +findAPI (TInterface ns n) = Just <$> findAPIByName (Name ns n) +findAPI _ = return Nothing + +findAPIByName :: Name -> CodeGen API +findAPIByName n@(Name ns _) = do + apis <- getAPIs + case M.lookup n apis of + Just api -> return api + Nothing -> + error $ "couldn't find API description for " ++ ns ++ "." ++ name n + +config :: CodeGen Config +config = ask + +line :: String -> CodeGen () +line = tell . Line + +blank :: CodeGen () +blank = line "" + +indent :: BaseCodeGen e a -> BaseCodeGen e a +indent cg = do + (x, code) <- recurse cg + tell $ Indent code + return x + +group :: BaseCodeGen e a -> BaseCodeGen e a +group cg = do + (x, code) <- recurse cg + tell $ Group code + blank + return x + +foreignImport :: BaseCodeGen e a -> BaseCodeGen e a +foreignImport cg = do + (a, c) <- recurse cg + tell $ ForeignImport c + return a + +codeToString c = unlines $ str 0 c [] + where str _ NoCode cont = cont + str n (Line s) cont = (replicate (n * 4) ' ' ++ s) : cont + str n (Indent c) cont = str (n + 1) c cont + str n (ForeignImport c) cont = str n c cont + str n (Sequence s) cont = deseq n (S.viewl s) cont + -- str n (Sequence s) cont = F.foldr (\code rest -> str n code : rest) cont s + str n (Group c) cont = str n c cont + + deseq _ S.EmptyL cont = cont + deseq n (c :< cs) cont = str n c (deseq n (S.viewl cs) cont) diff --git a/src/GI/Config.hs b/src/GI/Config.hs new file mode 100644 --- /dev/null +++ b/src/GI/Config.hs @@ -0,0 +1,14 @@ +module GI.Config + ( Config(..) + ) where + +import GI.Overrides (Overrides) + +data Config = Config { + -- | Name of the module being generated. + modName :: Maybe String, + -- | Whether to print extra info. + verbose :: Bool, + -- | List of loaded overrides for the code generator. + overrides :: Overrides + } diff --git a/src/GI/Constant.hs b/src/GI/Constant.hs new file mode 100644 --- /dev/null +++ b/src/GI/Constant.hs @@ -0,0 +1,71 @@ +module GI.Constant + ( genConstant + ) where + +import qualified Data.Text as T +import Data.Text (Text) + +import GI.API +import GI.Code +import GI.Conversions +import GI.Type + +genConstant :: Name -> Constant -> CodeGen () +genConstant (Name _ name) (Constant t value deprecated) = do + line $ "-- constant " ++ name + line $ deprecatedPragma name deprecated + + handleCGExc (\e -> line $ "-- XXX: Could not generate constant: " ++ describeCGError e) + (assignValue name t value) + +-- | Assign to the given name the given constant value, in a way that +-- can be assigned to the corresponding Haskell type. +assignValue :: String -> Type -> Text -> ExcCodeGen () +assignValue name t@(TBasicType b) value = do + ht <- haskellType t + line $ name ++ " :: " ++ show ht + hv <- showBasicType b value + line $ name ++ " = " ++ hv +assignValue name t@(TInterface _ _) value = do + ht <- haskellType t + api <- findAPI t + case api of + Just (APIEnum _) -> do + line $ name ++ " :: " ++ show ht + line $ name ++ " = toEnum " ++ T.unpack value + Just (APIFlags _) -> do + line $ name ++ " :: " ++ show ht + line $ name ++ " = wordToGFlags " ++ T.unpack value + Just (APIStruct s) | structIsBoxed s == False -> do + line $ name ++ " :: IO " ++ show ht + line $ name ++ " = do" + indent $ do + line $ "let ptr = intPtrToPtr " ++ T.unpack value + wrapped <- convert "ptr" (fToH t TransferNothing) + line $ "return " ++ wrapped + _ -> notImplementedError $ "Don't know how to treat constants of type " ++ show t +assignValue _ t _ = notImplementedError $ "Don't know how to treat constants of type " ++ show t + +-- | Show a basic type, in a way that can be assigned to the +-- corresponding Haskell type. +showBasicType :: BasicType -> Text -> ExcCodeGen String +showBasicType TInt8 i = return $ T.unpack i +showBasicType TUInt8 i = return $ T.unpack i +showBasicType TInt16 i = return $ T.unpack i +showBasicType TUInt16 i = return $ T.unpack i +showBasicType TInt32 i = return $ T.unpack i +showBasicType TUInt32 i = return $ T.unpack i +showBasicType TInt64 i = return $ T.unpack i +showBasicType TUInt64 i = return $ T.unpack i +showBasicType TBoolean "0" = return "False" +showBasicType TBoolean "false" = return "False" +showBasicType TBoolean "1" = return "True" +showBasicType TBoolean "true" = return "True" +showBasicType TBoolean b = notImplementedError $ "Could not parse boolean \"" ++ T.unpack b ++ "\"" +showBasicType TFloat f = return $ T.unpack f +showBasicType TDouble d = return $ T.unpack d +showBasicType TUTF8 s = return $ show s +showBasicType TFileName fn = return $ show fn +showBasicType TUniChar c = return $ "'" ++ T.unpack c ++ "'" +showBasicType TVoid ptr = return $ "intPtrToPtr " ++ T.unpack ptr +showBasicType TGType gtype = return $ "GType " ++ T.unpack gtype diff --git a/src/GI/Conversions.hs b/src/GI/Conversions.hs new file mode 100644 --- /dev/null +++ b/src/GI/Conversions.hs @@ -0,0 +1,772 @@ +{-# LANGUAGE PatternGuards, DeriveFunctor #-} + +module GI.Conversions + ( convert + , genConversion + , unpackCArray + , computeArrayLength + + , hToF + , fToH + , haskellType + , foreignType + + , argumentType + , elementType + , elementMap + , elementTypeAndMap + + , isManaged + , isNullable + + , getIsScalar + , requiresAlloc + + , apply + , mapC + , literal + , Constructor(..) + ) where + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative ((<$>)) +#endif +import Control.Monad (when) +import Control.Monad.Free (Free(..), liftF) +import Data.List (intercalate) +import Data.Typeable (TypeRep, tyConName, typeRepTyCon, typeOf) +import Data.Int +import qualified Data.Text as T +import Data.Word +import GHC.Exts (IsString(..)) + +import GI.API +import GI.Code +import GI.GObject +import GI.SymbolNaming +import GI.Type +import GI.Util + +-- String identifying a constructor in the generated code, which is +-- either (by default) a pure function (indicated by the P +-- constructor) or a function returning values on a monad (M +-- constructor). 'Id' denotes the identity function. +data Constructor = P String | M String | Id + deriving (Eq,Show) +instance IsString Constructor where + fromString = P + +data FExpr next = Apply Constructor next + | MapC Map Constructor next + | Literal Constructor next + deriving (Show, Functor) + +type Converter = Free FExpr () + +-- Different available maps. +data Map = Map | MapFirst | MapSecond + deriving (Show) + +-- Naming for the maps. +mapName :: Map -> String +mapName Map = "map" +mapName MapFirst = "mapFirst" +mapName MapSecond = "mapSecond" + +-- Naming for the monadic versions of the maps that we use +monadicMapName :: Map -> String +monadicMapName Map = "mapM" +monadicMapName MapFirst = "mapFirstA" +monadicMapName MapSecond = "mapSecondA" + +apply :: Constructor -> Converter +apply f = liftF $ Apply f () + +mapC :: Constructor -> Converter +mapC f = liftF $ MapC Map f () + +mapFirst :: Constructor -> Converter +mapFirst f = liftF $ MapC MapFirst f () + +mapSecond :: Constructor -> Converter +mapSecond f = liftF $ MapC MapSecond f () + +literal :: Constructor -> Converter +literal f = liftF $ Literal f () + +genConversion :: String -> Converter -> CodeGen String +genConversion l (Pure ()) = return l +genConversion l (Free k) = do + let l' = prime l + case k of + Apply (P f) next -> + do line $ "let " ++ l' ++ " = " ++ f ++ " " ++ l + genConversion l' next + Apply (M f) next -> + do line $ l' ++ " <- " ++ f ++ " " ++ l + genConversion l' next + Apply Id next -> genConversion l next + + MapC m (P f) next -> + do line $ "let " ++ l' ++ " = " ++ mapName m ++ " " ++ f ++ " " ++ l + genConversion l' next + MapC m (M f) next -> + do line $ l' ++ " <- " ++ monadicMapName m ++ " " ++ f ++ " " ++ l + genConversion l' next + MapC _ Id next -> genConversion l next + + Literal (P f) next -> + do line $ "let " ++ l ++ " = " ++ f + genConversion l next + Literal (M f) next -> + do line $ l ++ " <- " ++ f + genConversion l next + Literal Id next -> genConversion l next + +-- Given an array, together with its type, return the code for reading +-- its length. +computeArrayLength :: String -> Type -> ExcCodeGen String +computeArrayLength array (TCArray _ _ _ t) = do + reader <- findReader + return $ "fromIntegral $ " ++ reader ++ " " ++ array + where findReader = case t of + TBasicType TUInt8 -> return "B.length" + TBasicType _ -> return "length" + TInterface _ _ -> return "length" + TCArray{} -> return "length" + _ -> notImplementedError $ + "Don't know how to compute length of " ++ show t +computeArrayLength _ t = + notImplementedError $ "computeArrayLength called on non-CArray type " + ++ show t + +convert :: String -> BaseCodeGen e Converter -> BaseCodeGen e String +convert l c = do + c' <- c + genConversion l c' + +hObjectToF :: Type -> Transfer -> ExcCodeGen Constructor +hObjectToF t transfer = + if transfer == TransferEverything + then do + isGO <- isGObject t + if isGO + then return $ M "refObject" + else badIntroError "Transferring a non-GObject object" + -- castPtr since we accept any instance of the class associated with + -- the GObject, not just the precise type of the GObject, while the + -- foreign function declaration requires a pointer of the precise + -- type. + else return "unsafeManagedPtrCastPtr" + +hVariantToF :: Transfer -> CodeGen Constructor +hVariantToF transfer = + if transfer == TransferEverything + then return $ M "refGVariant" + else return "unsafeManagedPtrGetPtr" + +hParamSpecToF :: Transfer -> CodeGen Constructor +hParamSpecToF transfer = + if transfer == TransferEverything + then return $ M "refGParamSpec" + else return "unsafeManagedPtrGetPtr" + +hBoxedToF :: Transfer -> CodeGen Constructor +hBoxedToF transfer = + if transfer == TransferEverything + then return $ M "copyBoxed" + else return "unsafeManagedPtrGetPtr" + +hStructToF :: Struct -> Transfer -> ExcCodeGen Constructor +hStructToF s transfer = + if transfer /= TransferEverything || structIsBoxed s then + hBoxedToF transfer + else do + when (structSize s == 0) $ + badIntroError "Transferring a non-boxed struct with unknown size!" + return "unsafeManagedPtrGetPtr" + +hUnionToF :: Union -> Transfer -> ExcCodeGen Constructor +hUnionToF u transfer = + if transfer /= TransferEverything || unionIsBoxed u then + hBoxedToF transfer + else do + when (unionSize u == 0) $ + badIntroError "Transferring a non-boxed union with unknown size!" + return "unsafeManagedPtrGetPtr" + +-- Given the Haskell and Foreign types, returns the name of the +-- function marshalling between both. +hToF' :: Type -> Maybe API -> TypeRep -> TypeRep -> Transfer + -> ExcCodeGen Constructor +hToF' t a hType fType transfer + | ( hType == fType ) = return Id + | TError <- t = hBoxedToF transfer + | TVariant <- t = hVariantToF transfer + | TParamSpec <- t = hParamSpecToF transfer + | Just (APIEnum _) <- a = return "(fromIntegral . fromEnum)" + | Just (APIFlags _) <- a = return "gflagsToWord" + | Just (APIObject _) <- a = hObjectToF t transfer + | Just (APIInterface _) <- a = hObjectToF t transfer + | Just (APIStruct s) <- a = hStructToF s transfer + | Just (APIUnion u) <- a = hUnionToF u transfer + -- Converting callback types requires more context, we leave that + -- as a special case to be implemented by the caller. + | Just (APICallback _) <- a = error "Cannot handle callback type here!! " + | TByteArray <- t = return $ M "packGByteArray" + | TCArray True _ _ (TBasicType TUTF8) <- t = + return $ M "packZeroTerminatedUTF8CArray" + | TCArray True _ _ (TBasicType TFileName) <- t = + return $ M "packZeroTerminatedFileNameArray" + | TCArray True _ _ (TBasicType TVoid) <- t = + return $ M "packZeroTerminatedPtrArray" + | TCArray True _ _ (TBasicType TUInt8) <- t = + return $ M "packZeroTerminatedByteString" + | TCArray True _ _ (TBasicType TBoolean) <- t = + return $ M "(packMapZeroTerminatedStorableArray (fromIntegral . fromEnum))" + | TCArray True _ _ (TBasicType TGType) <- t = + return $ M "(packMapZeroTerminatedStorableArray gtypeToCGtype)" + | TCArray True _ _ (TBasicType _) <- t = + return $ M "packZeroTerminatedStorableArray" + | TCArray False _ _ (TBasicType TUTF8) <- t = + return $ M "packUTF8CArray" + | TCArray False _ _ (TBasicType TFileName) <- t = + return $ M "packFileNameArray" + | TCArray False _ _ (TBasicType TVoid) <- t = + return $ M "packPtrArray" + | TCArray False _ _ (TBasicType TUInt8) <- t = + return $ M "packByteString" + | TCArray False _ _ (TBasicType TBoolean) <- t = + return $ M "(packMapStorableArray (fromIntegral . fromEnum))" + | TCArray False _ _ (TBasicType TGType) <- t = + return $ M "(packMapStorableArray gtypeToCGType)" + | TCArray False _ _ (TBasicType TFloat) <- t = + return $ M "(packMapStorableArray realToFrac)" + | TCArray False _ _ (TBasicType TDouble) <- t = + return $ M "(packMapStorableArray realToFrac)" + | TCArray False _ _ (TBasicType _) <- t = + return $ M "packStorableArray" + | TCArray{} <- t = notImplementedError $ + "Don't know how to pack C array of type " ++ show t + | otherwise = case (show hType, show fType) of + ("T.Text", "CString") -> return $ M "textToCString" + ("[Char]", "CString") -> return $ M "stringToCString" + ("Char", "CInt") -> return "(fromIntegral . ord)" + ("Bool", "CInt") -> return "(fromIntegral . fromEnum)" + ("Float", "CFloat") -> return "realToFrac" + ("Double", "CDouble") -> return "realToFrac" + ("GType", "CGType") -> return "gtypeToCGType" + _ -> notImplementedError $ + "Don't know how to convert " + ++ show hType ++ " into " + ++ show fType ++ ".\n" + ++ "Internal type: " + ++ show t + +getForeignConstructor :: Type -> Transfer -> ExcCodeGen Constructor +getForeignConstructor t transfer = do + a <- findAPI t + hType <- haskellType t + fType <- foreignType t + hToF' t a hType fType transfer + +hToF_PackedType :: Type -> String -> Transfer -> ExcCodeGen Converter +hToF_PackedType t packer transfer = do + innerConstructor <- getForeignConstructor t transfer + return $ do + mapC innerConstructor + apply (M packer) + +-- | Try to find the `hash` and `equal` functions appropriate for the +-- given type, when used as a key in a GHashTable. +hashTableKeyMappings :: Type -> ExcCodeGen (String, String) +hashTableKeyMappings (TBasicType TVoid) = return ("gDirectHash", "gDirectEqual") +hashTableKeyMappings (TBasicType TUTF8) = return ("gStrHash", "gStrEqual") +hashTableKeyMappings t = + notImplementedError $ "GHashTable key of type " ++ show t ++ " unsupported." + +-- | `GHashTable` tries to fit every type into a pointer, the +-- following function tries to find the appropriate +-- (destroy,packer,unpacker) for the given type. +hashTablePtrPackers :: Type -> ExcCodeGen (String, String, String) +hashTablePtrPackers (TBasicType TVoid) = + return ("Nothing", "ptrPackPtr", "ptrUnpackPtr") +hashTablePtrPackers (TBasicType TUTF8) = + return ("(Just ptr_to_g_free)", "cstringPackPtr", "cstringUnpackPtr") +hashTablePtrPackers t = + notImplementedError $ "GHashTable element of type " ++ show t ++ " unsupported." + +hToF_PackGHashTable :: Type -> Type -> ExcCodeGen Converter +hToF_PackGHashTable keys elems = do + -- We will be adding elements to the Hash list with appropriate + -- destructors, so we always want a fresh copy. + keysConstructor <- getForeignConstructor keys TransferEverything + elemsConstructor <- getForeignConstructor elems TransferEverything + (keyHash, keyEqual) <- hashTableKeyMappings keys + (keyDestroy, keyPack, _) <- hashTablePtrPackers keys + (elemDestroy, elemPack, _) <- hashTablePtrPackers elems + return $ do + apply (P "Map.toList") + mapFirst keysConstructor + mapSecond elemsConstructor + mapFirst (P keyPack) + mapSecond (P elemPack) + apply (M (intercalate " " ["packGHashTable", keyHash, keyEqual, + keyDestroy, elemDestroy])) + +hToF :: Type -> Transfer -> ExcCodeGen Converter +hToF (TGList t) transfer = hToF_PackedType t "packGList" transfer +hToF (TGSList t) transfer = hToF_PackedType t "packGSList" transfer +hToF (TGArray t) transfer = hToF_PackedType t "packGArray" transfer +hToF (TPtrArray t) transfer = hToF_PackedType t "packGPtrArray" transfer +hToF (TGHash ta tb) _ = hToF_PackGHashTable ta tb +-- Arrays without length info are just passed along. +hToF (TCArray False (-1) (-1) _) _ = return $ Pure () +hToF (TCArray zt _ _ t@(TCArray{})) transfer = do + let packer = if zt + then "packZeroTerminated" + else "pack" + hToF_PackedType t (packer ++ "PtrArray") transfer + +hToF (TCArray zt _ _ t@(TInterface _ _)) transfer = do + isScalar <- getIsScalar t + let packer = if zt + then "packZeroTerminated" + else "pack" + if isScalar + then hToF_PackedType t (packer ++ "StorableArray") transfer + else do + api <- findAPI t + let size = case api of + Just (APIStruct s) -> structSize s + Just (APIUnion u) -> unionSize u + _ -> 0 + if size == 0 || zt + then hToF_PackedType t (packer ++ "PtrArray") transfer + else hToF_PackedType t (packer ++ "BlockArray " ++ show size) transfer + +hToF t transfer = do + a <- findAPI t + hType <- haskellType t + fType <- foreignType t + constructor <- hToF' t a hType fType transfer + return $ apply constructor + +boxedForeignPtr :: String -> Transfer -> CodeGen Constructor +boxedForeignPtr constructor transfer = return $ + case transfer of + TransferEverything -> M $ parenthesize $ "wrapBoxed " ++ constructor + _ -> M $ parenthesize $ "newBoxed " ++ constructor + +suForeignPtr :: Bool -> Int -> TypeRep -> Transfer -> CodeGen Constructor +suForeignPtr isBoxed size hType transfer = do + let constructor = tyConName $ typeRepTyCon hType + if isBoxed then + boxedForeignPtr constructor transfer + else case size of + 0 -> do + line "-- XXX Wrapping a foreign struct/union with no known destructor, leak?" + return $ M $ parenthesize $ + "\\x -> " ++ constructor ++ " <$> newForeignPtr_ x" + n -> return $ M $ parenthesize $ + case transfer of + TransferEverything -> "wrapPtr " ++ constructor + _ -> "newPtr " ++ show n ++ " " ++ constructor + +structForeignPtr :: Struct -> TypeRep -> Transfer -> CodeGen Constructor +structForeignPtr s = + suForeignPtr (structIsBoxed s) (structSize s) + +unionForeignPtr :: Union -> TypeRep -> Transfer -> CodeGen Constructor +unionForeignPtr u = + suForeignPtr (unionIsBoxed u) (unionSize u) + +fObjectToH :: Type -> TypeRep -> Transfer -> ExcCodeGen Constructor +fObjectToH t hType transfer = do + let constructor = tyConName $ typeRepTyCon hType + isGO <- isGObject t + case transfer of + TransferEverything -> + if isGO + then return $ M $ parenthesize $ "wrapObject " ++ constructor + else badIntroError "Got a transfer of something not a GObject" + _ -> + if isGO + then return $ M $ parenthesize $ "newObject " ++ constructor + else badIntroError "Wrapping not a GObject with no copy..." + +fCallbackToH :: Callback -> TypeRep -> Transfer -> ExcCodeGen Constructor +fCallbackToH _ _ _ = + notImplementedError "Wrapping foreign callbacks is not supported yet" + +fVariantToH :: Transfer -> CodeGen Constructor +fVariantToH transfer = + return $ M $ case transfer of + TransferEverything -> "wrapGVariantPtr" + _ -> "newGVariantFromPtr" + +fParamSpecToH :: Transfer -> CodeGen Constructor +fParamSpecToH transfer = + return $ M $ case transfer of + TransferEverything -> "wrapGParamSpecPtr" + _ -> "newGParamSpecFromPtr" + +fToH' :: Type -> Maybe API -> TypeRep -> TypeRep -> Transfer + -> ExcCodeGen Constructor +fToH' t a hType fType transfer + | ( hType == fType ) = return Id + | Just (APIEnum _) <- a = return "(toEnum . fromIntegral)" + | Just (APIFlags _) <- a = return "wordToGFlags" + | TError <- t = boxedForeignPtr "GError" transfer + | TVariant <- t = fVariantToH transfer + | TParamSpec <- t = fParamSpecToH transfer + | Just (APIStruct s) <- a = structForeignPtr s hType transfer + | Just (APIUnion u) <- a = unionForeignPtr u hType transfer + | Just (APIObject _) <- a = fObjectToH t hType transfer + | Just (APIInterface _) <- a = fObjectToH t hType transfer + | Just (APICallback c) <- a = fCallbackToH c hType transfer + | TCArray True _ _ (TBasicType TUTF8) <- t = + return $ M "unpackZeroTerminatedUTF8CArray" + | TCArray True _ _ (TBasicType TFileName) <- t = + return $ M "unpackZeroTerminatedFileNameArray" + | TCArray True _ _ (TBasicType TUInt8) <- t = + return $ M "unpackZeroTerminatedByteString" + | TCArray True _ _ (TBasicType TVoid) <- t = + return $ M "unpackZeroTerminatedPtrArray" + | TCArray True _ _ (TBasicType TBoolean) <- t = + return $ M "(unpackMapZeroTerminatedStorableArray (/= 0))" + | TCArray True _ _ (TBasicType TGType) <- t = + return $ M "(unpackMapZeroTerminatedStorableArray GType)" + | TCArray True _ _ (TBasicType TFloat) <- t = + return $ M "(unpackMapZeroTerminatedStorableArray realToFrac)" + | TCArray True _ _ (TBasicType TDouble) <- t = + return $ M "(unpackMapZeroTerminatedStorableArray realToFrac)" + | TCArray True _ _ (TBasicType _) <- t = + return $ M "unpackZeroTerminatedStorableArray" + | TCArray{} <- t = notImplementedError $ + "Don't know how to unpack C array of type " ++ show t + | TByteArray <- t = return $ M "unpackGByteArray" + | TGHash _ _ <- t = notImplementedError "Foreign Hashes not supported yet" + | otherwise = case (show fType, show hType) of + ("CString", "T.Text") -> return $ M "cstringToText" + ("CString", "[Char]") -> return $ M "cstringToString" + ("CInt", "Char") -> return "(chr . fromIntegral)" + ("CInt", "Bool") -> return "(/= 0)" + ("CFloat", "Float") -> return "realToFrac" + ("CDouble", "Double") -> return "realToFrac" + ("CGType", "GType") -> return "GType" + _ -> + notImplementedError $ "Don't know how to convert " + ++ show fType ++ " into " + ++ show hType ++ ".\n" + ++ "Internal type: " + ++ show t + +getHaskellConstructor :: Type -> Transfer -> ExcCodeGen Constructor +getHaskellConstructor t transfer = do + a <- findAPI t + hType <- haskellType t + fType <- foreignType t + fToH' t a hType fType transfer + +fToH_PackedType :: Type -> String -> Transfer -> ExcCodeGen Converter +fToH_PackedType t unpacker transfer = do + innerConstructor <- getHaskellConstructor t transfer + return $ do + apply (M unpacker) + mapC innerConstructor + +fToH_UnpackGHashTable :: Type -> Type -> Transfer -> ExcCodeGen Converter +fToH_UnpackGHashTable keys elems transfer = do + keysConstructor <- getHaskellConstructor keys transfer + (_,_,keysUnpack) <- hashTablePtrPackers keys + elemsConstructor <- getHaskellConstructor elems transfer + (_,_,elemsUnpack) <- hashTablePtrPackers elems + return $ do + apply (M "unpackGHashTable") + mapFirst (P keysUnpack) + mapFirst keysConstructor + mapSecond (P elemsUnpack) + mapSecond elemsConstructor + apply (P "Map.fromList") + +fToH :: Type -> Transfer -> ExcCodeGen Converter + +fToH (TGList t) transfer = fToH_PackedType t "unpackGList" transfer +fToH (TGSList t) transfer = fToH_PackedType t "unpackGSList" transfer +fToH (TGArray t) transfer = fToH_PackedType t "unpackGArray" transfer +fToH (TPtrArray t) transfer = fToH_PackedType t "unpackGPtrArray" transfer +fToH (TGHash a b) transfer = fToH_UnpackGHashTable a b transfer +-- Arrays without length info are just passed along. +fToH (TCArray False (-1) (-1) _) _ = return $ Pure () +fToH (TCArray True _ _ t@(TCArray{})) transfer = + fToH_PackedType t "unpackZeroTerminatedPtrArray" transfer +fToH (TCArray True _ _ t@(TInterface _ _)) transfer = do + isScalar <- getIsScalar t + if isScalar + then fToH_PackedType t "unpackZeroTerminatedStorableArray" transfer + else fToH_PackedType t "unpackZeroTerminatedPtrArray" transfer + +fToH t transfer = do + a <- findAPI t + hType <- haskellType t + fType <- foreignType t + constructor <- fToH' t a hType fType transfer + return $ apply constructor + +unpackCArray :: String -> Type -> Transfer -> ExcCodeGen Converter +unpackCArray length (TCArray False _ _ t) transfer = + case t of + TBasicType TUTF8 -> return $ apply $ M $ parenthesize $ + "unpackUTF8CArrayWithLength " ++ length + TBasicType TFileName -> return $ apply $ M $ parenthesize $ + "unpackFileNameArrayWithLength " ++ length + TBasicType TUInt8 -> return $ apply $ M $ parenthesize $ + "unpackByteStringWithLength " ++ length + TBasicType TVoid -> return $ apply $ M $ parenthesize $ + "unpackPtrArrayWithLength " ++ length + TBasicType TBoolean -> return $ apply $ M $ parenthesize $ + "unpackMapStorableArrayWithLength (/= 0) " ++ length + TBasicType TGType -> return $ apply $ M $ parenthesize $ + "unpackMapStorableArrayWithLength GType " ++ length + TBasicType TFloat -> return $ apply $ M $ parenthesize $ + "unpackMapStorableArrayWithLength realToFrac " ++ length + TBasicType TDouble -> return $ apply $ M $ parenthesize $ + "unpackMapStorableArrayWithLength realToFrac " ++ length + TBasicType _ -> return $ apply $ M $ parenthesize $ + "unpackStorableArrayWithLength " ++ length + TInterface _ _ -> do + a <- findAPI t + isScalar <- getIsScalar t + hType <- haskellType t + fType <- foreignType t + innerConstructor <- fToH' t a hType fType transfer + let (boxed, size) = case a of + Just (APIStruct s) -> (structIsBoxed s, structSize s) + Just (APIUnion u) -> (unionIsBoxed u, unionSize u) + _ -> (False, 0) + let unpacker | isScalar = "unpackStorableArrayWithLength" + | (size == 0) = "unpackPtrArrayWithLength" + | boxed = "unpackBoxedArrayWithLength " ++ show size + | otherwise = "unpackBlockArrayWithLength " ++ show size + return $ do + apply $ M $ parenthesize $ unpacker ++ " " ++ length + mapC innerConstructor + _ -> notImplementedError $ + "unpackCArray : Don't know how to unpack C Array of type " ++ show t + +unpackCArray _ _ _ = notImplementedError "unpackCArray : unexpected array type." + +-- Given a type find the typeclasses the type belongs to, and return +-- the representation of the type in the function signature and the +-- list of typeclass constraints for the type. +argumentType :: [Char] -> Type -> CodeGen ([Char], String, [String]) +argumentType [] _ = error "out of letters" +argumentType letters (TGList a) = do + (ls, name, constraints) <- argumentType letters a + return (ls, "[" ++ name ++ "]", constraints) +argumentType letters (TGSList a) = do + (ls, name, constraints) <- argumentType letters a + return (ls, "[" ++ name ++ "]", constraints) +argumentType letters@(l:ls) t = do + api <- findAPI t + s <- show <$> haskellType t + case api of + Just (APIInterface _) -> do + let constraints = [classConstraint s ++ " " ++ [l]] + return (ls, [l], constraints) + -- Instead of restricting to the actual class, + -- we allow for any object descending from it. + Just (APIObject _) -> do + isGO <- isGObject t + if isGO + then return (ls, [l], [classConstraint s ++ " " ++ [l]]) + else return (letters, s, []) + _ -> return (letters, s, []) + +haskellBasicType TVoid = ptr $ typeOf () +haskellBasicType TBoolean = typeOf True +haskellBasicType TInt8 = typeOf (0 :: Int8) +haskellBasicType TUInt8 = typeOf (0 :: Word8) +haskellBasicType TInt16 = typeOf (0 :: Int16) +haskellBasicType TUInt16 = typeOf (0 :: Word16) +haskellBasicType TInt32 = typeOf (0 :: Int32) +haskellBasicType TUInt32 = typeOf (0 :: Word32) +haskellBasicType TInt64 = typeOf (0 :: Int64) +haskellBasicType TUInt64 = typeOf (0 :: Word64) +haskellBasicType TGType = "GType" `con` [] +haskellBasicType TUTF8 = "T.Text" `con` [] +haskellBasicType TFloat = typeOf (0 :: Float) +haskellBasicType TDouble = typeOf (0 :: Double) +haskellBasicType TUniChar = typeOf ('\0' :: Char) +haskellBasicType TFileName = "[Char]" `con` [] + +-- This translates GI types to the types used for generated Haskell code. +haskellType :: Type -> CodeGen TypeRep +haskellType (TBasicType bt) = return $ haskellBasicType bt +-- We cannot really do anything sensible for a foreign array with no +-- length info, so just pass the pointer along. +haskellType (TCArray False (-1) (-1) t) = + ptr <$> foreignType t +haskellType (TCArray _ _ _ (TBasicType TUInt8)) = + return $ "ByteString" `con` [] +haskellType (TCArray _ _ _ a) = do + inner <- haskellType a + return $ "[]" `con` [inner] +haskellType (TGArray a) = do + inner <- haskellType a + return $ "[]" `con` [inner] +haskellType (TPtrArray a) = do + inner <- haskellType a + return $ "[]" `con` [inner] +haskellType (TByteArray) = return $ "ByteString" `con` [] +haskellType (TGList a) = do + inner <- haskellType a + return $ "[]" `con` [inner] +haskellType (TGSList a) = do + inner <- haskellType a + return $ "[]" `con` [inner] +haskellType (TGHash a b) = do + innerA <- haskellType a + innerB <- haskellType b + return $ "Map.Map" `con` [innerA, innerB] +haskellType TError = return $ "GError" `con` [] +haskellType TVariant = return $ "GVariant" `con` [] +haskellType TParamSpec = return $ "GParamSpec" `con` [] +haskellType (TInterface "GObject" "Value") = return $ "GValue" `con` [] +haskellType (TInterface "GObject" "Closure") = return $ "Closure" `con` [] +haskellType t@(TInterface ns n) = do + prefix <- qualify ns + api <- findAPI t + let tname = T.pack (prefix ++ n) `con` [] + return $ case api of + Just (APIFlags _) -> "[]" `con` [tname] + _ -> tname + +foreignBasicType TVoid = ptr (typeOf ()) +foreignBasicType TBoolean = "CInt" `con` [] +foreignBasicType TUTF8 = "CString" `con` [] +foreignBasicType TFileName = "CString" `con` [] +foreignBasicType TUniChar = "CInt" `con` [] +foreignBasicType TFloat = "CFloat" `con` [] +foreignBasicType TDouble = "CDouble" `con` [] +foreignBasicType TGType = "CGType" `con` [] +foreignBasicType t = haskellBasicType t + +-- This translates GI types to the types used in foreign function calls. +foreignType :: Type -> CodeGen TypeRep +foreignType (TBasicType t) = return $ foreignBasicType t +foreignType (TCArray False (-1) (-1) t) = + ptr <$> foreignType t +foreignType (TCArray zt _ _ t) = do + api <- findAPI t + let size = case api of + Just (APIStruct s) -> structSize s + Just (APIUnion u) -> unionSize u + _ -> 0 + if size == 0 || zt + then ptr <$> foreignType t + else foreignType t +foreignType (TGArray a) = do + inner <- foreignType a + return $ ptr ("GArray" `con` [inner]) +foreignType (TPtrArray a) = do + inner <- foreignType a + return $ ptr ("GPtrArray" `con` [inner]) +foreignType (TByteArray) = return $ ptr ("GByteArray" `con` []) +foreignType (TGList a) = do + inner <- foreignType a + return $ ptr ("GList" `con` [inner]) +foreignType (TGSList a) = do + inner <- foreignType a + return $ ptr ("GSList" `con` [inner]) +foreignType (TGHash a b) = do + innerA <- foreignType a + innerB <- foreignType b + return $ ptr ("GHashTable" `con` [innerA, innerB]) +foreignType t@TError = ptr <$> haskellType t +foreignType t@TVariant = ptr <$> haskellType t +foreignType t@TParamSpec = ptr <$> haskellType t +foreignType (TInterface "GObject" "Value") = return $ ptr $ "GValue" `con` [] +foreignType (TInterface "GObject" "Closure") = + return $ ptr $ "Closure" `con` [] +foreignType t@(TInterface ns n) = do + isScalar <- getIsScalar t + if isScalar + then return $ "CUInt" `con` [] + else do + api <- findAPI t + prefix <- qualify ns + return $ case api of + Just (APICallback _) -> T.pack ("FunPtr " ++ prefix ++ n ++ "C") + `con` [] + _ -> ptr $ T.pack (prefix ++ n) `con` [] + +getIsScalar :: Type -> CodeGen Bool +getIsScalar t = do + a <- findAPI t + case a of + Nothing -> return False + (Just (APIEnum _)) -> return True + (Just (APIFlags _)) -> return True + _ -> return False + +-- Whether the given type corresponds to a struct we allocate +-- ourselves. If we need to allocate the struct we return its size in +-- bytes and whether the type is boxed, otherwise we return Nothing. +requiresAlloc :: Type -> CodeGen (Maybe (Bool, Int)) +requiresAlloc t = do + api <- findAPI t + case api of + Just (APIStruct s) -> case structSize s of + 0 -> return Nothing + n -> return (Just (structIsBoxed s, n)) + _ -> return Nothing + +-- Returns whether the given type corresponds to a ManagedPtr +-- instance (a thin wrapper over a ForeignPtr). +isManaged :: Type -> CodeGen Bool +isManaged t = do + a <- findAPI t + case a of + Just (APIObject _) -> return True + Just (APIInterface _) -> return True + Just (APIStruct _) -> return True + Just (APIUnion _) -> return True + _ -> return False + +-- Returns whether the given type is nullable in the C sense, +-- i.e. whether it can be set to NULL. +isNullable :: Type -> Bool +isNullable (TBasicType TVoid) = True +isNullable (TBasicType TUTF8) = True +isNullable (TBasicType TFileName) = True +isNullable (TBasicType _) = False +isNullable _ = True + +-- If the given type maps to a list in Haskell, return the type of the +-- elements, and the function that maps over them. +elementTypeAndMap :: Type -> String -> Maybe (Type, String) +-- Passed along as a raw pointer. +elementTypeAndMap (TCArray False (-1) (-1) _) _ = Nothing +-- ByteString +elementTypeAndMap (TCArray _ _ _ (TBasicType TUInt8)) _ = Nothing +elementTypeAndMap (TCArray True _ _ t) _ = Just (t, "mapZeroTerminatedCArray") +elementTypeAndMap (TCArray False (-1) _ t) len = + Just (t, parenthesize $ "mapCArrayWithLength " ++ len) +elementTypeAndMap (TCArray False fixed _ t) _ = + Just (t, parenthesize $ "mapCArrayWithLength " ++ show fixed) +elementTypeAndMap (TGArray t) _ = Just (t, "mapGArray") +elementTypeAndMap (TPtrArray t) _ = Just (t, "mapPtrArray") +elementTypeAndMap (TGList t) _ = Just (t, "mapGList") +elementTypeAndMap (TGSList t) _ = Just (t, "mapGSList") +-- GHashTable is treated separately, see Transfer.hs +elementTypeAndMap _ _ = Nothing + +-- Return just the element type. +elementType :: Type -> Maybe Type +elementType t = fst <$> elementTypeAndMap t undefined + +-- Return just the map. +elementMap :: Type -> String -> Maybe String +elementMap t len = snd <$> elementTypeAndMap t len diff --git a/src/GI/GIR/Alias.hs b/src/GI/GIR/Alias.hs new file mode 100644 --- /dev/null +++ b/src/GI/GIR/Alias.hs @@ -0,0 +1,40 @@ +module GI.GIR.Alias + ( documentListAliases + ) where + +import qualified Data.Map as M +import Data.Text (Text) +import qualified Data.Text as T +import Text.XML (Element(elementAttributes), Document(documentRoot)) + +import GI.Type (Type) +import GI.GIR.BasicTypes (Alias(..)) +import GI.GIR.Type (parseType) +import GI.GIR.Parser +import GI.GIR.XMLUtils (childElemsWithLocalName) + +-- | Find all aliases in a given namespace. +namespaceListAliases :: Element -> M.Map Alias Type +namespaceListAliases ns = + case M.lookup "name" (elementAttributes ns) of + Nothing -> error $ "Namespace with no name!" + Just nsName -> case runParser nsName M.empty ns parseAliases of + Left err -> (error . T.unpack) err + Right aliases -> M.fromList (map addNS aliases) + where addNS (n, t) = (Alias (nsName, n), t) + +-- | Parse all the aliases in the current namespace +parseAliases :: Parser [(Text, Type)] +parseAliases = parseChildrenWithLocalName "alias" parseAlias + +-- | Parse a single alias +parseAlias :: Parser (Text, Type) +parseAlias = do + name <- getAttr "name" + t <- parseType + return (name, t) + +-- | Find all aliases in a given document. +documentListAliases :: Document -> M.Map Alias Type +documentListAliases doc = M.unions (map namespaceListAliases namespaces) + where namespaces = childElemsWithLocalName "namespace" (documentRoot doc) diff --git a/src/GI/GIR/BasicTypes.hs b/src/GI/GIR/BasicTypes.hs new file mode 100644 --- /dev/null +++ b/src/GI/GIR/BasicTypes.hs @@ -0,0 +1,21 @@ +-- | Basic types used in GIR parsing. +module GI.GIR.BasicTypes + ( Name(..) + , Transfer(..) + , Alias(..) + ) where + +import Data.Text (Text) + +-- | Name for a symbol in the GIR file. +data Name = Name { namespace :: String, name :: String } + deriving (Eq, Ord, Show) + +-- | Transfer mode for an argument or property. +data Transfer = TransferNothing + | TransferContainer + | TransferEverything + deriving (Show, Eq, Ord) + +-- | An alias, which is simply (Namespace, name). +newtype Alias = Alias (Text, Text) deriving (Ord, Eq, Show) diff --git a/src/GI/GIR/Callback.hs b/src/GI/GIR/Callback.hs new file mode 100644 --- /dev/null +++ b/src/GI/GIR/Callback.hs @@ -0,0 +1,17 @@ +-- | Parsing of callbacks. +module GI.GIR.Callback + ( Callback(..) + , parseCallback + ) where + +import GI.GIR.Parser +import GI.GIR.Callable (Callable, parseCallable) + +data Callback = Callback Callable + deriving Show + +parseCallback :: Parser (Name, Callback) +parseCallback = do + name <- parseName + callable <- parseCallable + return (name, Callback callable) diff --git a/src/GI/GIR/Constant.hs b/src/GI/GIR/Constant.hs new file mode 100644 --- /dev/null +++ b/src/GI/GIR/Constant.hs @@ -0,0 +1,27 @@ +-- | Parsing of constants in GIR files. +module GI.GIR.Constant + ( Constant(..) + , parseConstant + ) where + +import Data.Text (Text) + +import GI.Type (Type) +import GI.GIR.Type (parseType) +import GI.GIR.Parser + +-- | Info about a constant. +data Constant = Constant { + constantType :: Type, + constantValue :: Text, + constantDeprecated :: Maybe DeprecationInfo + } deriving (Show) + +-- | Parse a "constant" element from the GIR file. +parseConstant :: Parser (Name, Constant) +parseConstant = do + name <- parseName + deprecated <- parseDeprecation + value <- getAttr "value" + t <- parseType + return (name, Constant t value deprecated) diff --git a/src/GI/GIR/Deprecation.hs b/src/GI/GIR/Deprecation.hs new file mode 100644 --- /dev/null +++ b/src/GI/GIR/Deprecation.hs @@ -0,0 +1,42 @@ +module GI.GIR.Deprecation + ( DeprecationInfo + , deprecatedPragma + , queryDeprecated + ) where + +import qualified Data.Map as M +import qualified Data.Text as T +import Data.Text (Text) +import Text.XML (Element(elementAttributes)) + +import GI.GIR.XMLUtils (firstChildWithLocalName, getElementContent) + +-- | Deprecation information on a symbol. +data DeprecationInfo = DeprecationInfo { + deprecatedSinceVersion :: Maybe Text, + deprecationMessage :: Maybe Text + } deriving (Show, Eq) + +-- | Encode the given `DeprecationInfo` for the given symbol as a +-- deprecation pragma. +deprecatedPragma :: String -> Maybe DeprecationInfo -> String +deprecatedPragma _ Nothing = "" +deprecatedPragma name (Just info) = "{-# DEPRECATED " ++ name ++ " " ++ + show (note ++ reason) ++ "#-}" + where reason = case deprecationMessage info of + Nothing -> [] + Just msg -> (lines . T.unpack) msg + note = case deprecatedSinceVersion info of + Nothing -> [] + Just v -> ["(Since version " ++ T.unpack v ++ ")"] + +-- | Parse the deprecation information for the given element of the GIR file. +queryDeprecated :: Element -> Maybe DeprecationInfo +queryDeprecated element = + case M.lookup "deprecated" attrs of + Just _ -> let version = M.lookup "deprecated-version" attrs + msg = firstChildWithLocalName "doc-deprecated" element >>= + getElementContent + in Just (DeprecationInfo version msg) + Nothing -> Nothing + where attrs = elementAttributes element diff --git a/src/GI/GIR/Enum.hs b/src/GI/GIR/Enum.hs new file mode 100644 --- /dev/null +++ b/src/GI/GIR/Enum.hs @@ -0,0 +1,52 @@ +-- | Parsing of Enums. +module GI.GIR.Enum + ( Enumeration(..) + , parseEnum + ) where + +import Data.Int (Int64) +import Data.Text (Text) +import Foreign.C (CInt(..)) + +import GI.GIR.Parser + +data Enumeration = Enumeration { + enumValues :: [(Text, Int64)], + errorDomain :: Maybe Text, + enumTypeInit :: Maybe Text, + enumStorageBytes :: Int, -- ^ Bytes used for storage of this struct. + enumDeprecated :: Maybe DeprecationInfo } + deriving Show + +-- | Parse a struct member. +parseEnumMember :: Parser (Text, Int64) +parseEnumMember = do + name <- getAttr "name" + value <- getAttr "value" >>= parseIntegral + return (name, value) + +foreign import ccall "_gi_get_enum_storage_bytes" get_storage_bytes :: + Int64 -> Int64 -> CInt + +-- | Return the number of bytes that should be allocated for storage +-- of the given values in an enum. +extractEnumStorageBytes :: [Int64] -> Int +extractEnumStorageBytes values = + fromIntegral $ get_storage_bytes (minimum values) (maximum values) + +-- | Parse an "enumeration" element from the GIR file. +parseEnum :: Parser (Name, Enumeration) +parseEnum = do + name <- parseName + deprecated <- parseDeprecation + errorDomain <- queryAttrWithNamespace GLibGIRNS "error-domain" + typeInit <- queryAttrWithNamespace GLibGIRNS "get-type" + values <- parseChildrenWithLocalName "member" parseEnumMember + return (name, + Enumeration { + enumValues = values + , errorDomain = errorDomain + , enumTypeInit = typeInit + , enumStorageBytes = extractEnumStorageBytes (map snd values) + , enumDeprecated = deprecated + }) diff --git a/src/GI/GIR/Field.hs b/src/GI/GIR/Field.hs new file mode 100644 --- /dev/null +++ b/src/GI/GIR/Field.hs @@ -0,0 +1,75 @@ +-- | Parsing of object/struct/union fields. +module GI.GIR.Field + ( Field(..) + , FieldInfoFlag + , parseFields + ) where + +import Data.Monoid ((<>)) +import Data.Text (Text) + +import GI.Type (Type(..)) + +import GI.GIR.Callback (Callback, parseCallback) +import GI.GIR.Type (parseType) +import GI.GIR.Parser + +data Field = Field { + fieldName :: Text, + fieldVisible :: Bool, + fieldType :: Type, + fieldCallback :: Maybe Callback, + fieldOffset :: Int, + fieldFlags :: [FieldInfoFlag], + fieldDeprecated :: Maybe DeprecationInfo } + deriving Show + +data FieldInfoFlag = FieldIsReadable | FieldIsWritable + deriving Show + +-- | Parse a single field in a struct or union. We parse +-- non-introspectable fields too (but set fieldVisible = False for +-- them), this is necessary since they affect the computation of +-- offsets of fields and sizes of containing structs. +parseField :: Parser Field +parseField = do + name <- getAttr "name" + deprecated <- parseDeprecation + readable <- optionalAttr "readable" True parseBool + writable <- optionalAttr "writable" False parseBool + let flags = if readable then [FieldIsReadable] else [] + <> if writable then [FieldIsWritable] else [] + introspectable <- optionalAttr "introspectable" True parseBool + private <- optionalAttr "private" False parseBool + (t, callback) <- + if introspectable + then do + callbacks <- parseChildrenWithLocalName "callback" parseCallback + (cbn, callback) <- case callbacks of + [] -> return (Nothing, Nothing) + [(n, cb)] -> return (Just n, Just cb) + _ -> parseError "Multiple callbacks in field" + t <- case cbn of + Nothing -> parseType + Just (Name ns n) -> return (TInterface ns n) + return (t, callback) + else do + callbacks <- parseAllChildrenWithLocalName "callback" parseName + case callbacks of + [] -> do + t <- parseType + return (t, Nothing) + [Name ns n] -> return (TInterface ns n, Nothing) + _ -> parseError "Multiple callbacks in field" + return $ Field { + fieldName = name + , fieldVisible = introspectable && not private + , fieldType = t + , fieldCallback = callback + , fieldOffset = error ("unfixed field offset " ++ show name) + , fieldFlags = flags + , fieldDeprecated = deprecated + } + +parseFields :: Parser [Field] +parseFields = parseAllChildrenWithLocalName "field" parseField diff --git a/src/GI/GIR/Flags.hs b/src/GI/GIR/Flags.hs new file mode 100644 --- /dev/null +++ b/src/GI/GIR/Flags.hs @@ -0,0 +1,17 @@ +-- | Parsing of bitfields, a.k.a. flags. They are represented in the +-- same way as enums, so this is a thin wrapper over that code. +module GI.GIR.Flags + ( Flags(..) + , parseFlags + ) where + +import GI.GIR.Enum (Enumeration, parseEnum) +import GI.GIR.Parser + +data Flags = Flags Enumeration + deriving Show + +parseFlags :: Parser (Name, Flags) +parseFlags = do + (n, enum) <- parseEnum + return (n, Flags enum) diff --git a/src/GI/GIR/Method.hs b/src/GI/GIR/Method.hs new file mode 100644 --- /dev/null +++ b/src/GI/GIR/Method.hs @@ -0,0 +1,42 @@ +module GI.GIR.Method + ( Method(..) + , MethodType(..) + , parseMethod + ) where + +import Data.Text (Text) +import qualified Data.Text as T + +import GI.GIR.Callable (Callable(..), parseCallable) +import GI.GIR.Parser + +data MethodType = Constructor -- ^ Constructs an instance of the parent type + | MemberFunction -- ^ A function in the namespace + | OrdinaryMethod -- ^ A function taking the parent + -- instance as first argument. + deriving (Eq, Show) + +data Method = Method { + methodSymbol :: Text, + methodThrows :: Bool, + methodType :: MethodType, + methodCallable :: Callable + } deriving Show + +parseMethod :: MethodType -> Parser (Name, Method) +parseMethod mType = do + name <- parseName + shadows <- queryAttr "shadows" + let exposedName = case shadows of + Just n -> name {name = T.unpack n} + Nothing -> name + callable <- parseCallable + symbol <- getAttrWithNamespace CGIRNS "identifier" + throws <- optionalAttr "throws" False parseBool + return $ (exposedName, + Method { + methodSymbol = symbol + , methodThrows = throws + , methodType = mType + , methodCallable = callable + }) diff --git a/src/GI/GIR/Object.hs b/src/GI/GIR/Object.hs new file mode 100644 --- /dev/null +++ b/src/GI/GIR/Object.hs @@ -0,0 +1,49 @@ +-- | Parsing of objects. +module GI.GIR.Object + ( Object(..) + , parseObject + ) where + +import Data.Text (Text) + +import GI.GIR.Method (Method, parseMethod, MethodType(..)) +import GI.GIR.Property (Property, parseProperty) +import GI.GIR.Signal (Signal, parseSignal) +import GI.GIR.Parser + +data Object = Object { + objParent :: Maybe Name, + objTypeInit :: Text, + objTypeName :: Text, + objInterfaces :: [Name], + objDeprecated :: Maybe DeprecationInfo, + objMethods :: [(Name, Method)], + objProperties :: [Property], + objSignals :: [Signal] + } deriving Show + +parseObject :: Parser (Name, Object) +parseObject = do + name <- parseName + deprecated <- parseDeprecation + methods <- parseChildrenWithLocalName "method" (parseMethod OrdinaryMethod) + constructors <- parseChildrenWithLocalName "constructor" (parseMethod Constructor) + functions <- parseChildrenWithLocalName "function" (parseMethod MemberFunction) + parent <- optionalAttr "parent" Nothing (fmap Just . qualifyName) + interfaces <- parseChildrenWithLocalName "implements" parseName + props <- parseChildrenWithLocalName "property" parseProperty + typeInit <- getAttrWithNamespace GLibGIRNS "get-type" + typeName <- getAttrWithNamespace GLibGIRNS "type-name" + signals <- parseChildrenWithNSName GLibGIRNS "signal" parseSignal + return (name, + Object { + objParent = parent + , objTypeInit = typeInit + , objTypeName = typeName + , objInterfaces = interfaces + , objDeprecated = deprecated + , objMethods = constructors ++ methods ++ functions + , objProperties = props + , objSignals = signals + }) + diff --git a/src/GI/GIR/Parser.hs b/src/GI/GIR/Parser.hs new file mode 100644 --- /dev/null +++ b/src/GI/GIR/Parser.hs @@ -0,0 +1,230 @@ +-- | The Parser monad. +module GI.GIR.Parser + ( Parser + , ParseError + , parseError + + , runParser + + , parseName + , parseDeprecation + , parseIntegral + , parseBool + , parseChildrenWithLocalName + , parseAllChildrenWithLocalName + , parseChildrenWithNSName + + , getAttr + , getAttrWithNamespace + , queryAttr + , queryAttrWithNamespace + , optionalAttr + + , currentNamespace + , qualifyName + , resolveQualifiedTypeName + + -- Reexported for convenience + , Name(..) + , Element + , GIRXMLNamespace(..) + , DeprecationInfo + ) where + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative ((<$>)) +#endif + +import Control.Monad.Except +import Control.Monad.Reader + +import Data.Monoid ((<>)) +import qualified Data.Map as M +import qualified Data.Text as T +import qualified Data.Text.Read as TR +import Data.Text (Text) +import qualified Text.XML as XML +import Text.XML (Element(elementAttributes)) +import Text.Show.Pretty (ppShow) + +import GI.Type (Type(TInterface)) + +import GI.GIR.BasicTypes (Name(..), Alias(..)) +import GI.GIR.Deprecation (DeprecationInfo, queryDeprecated) +import GI.GIR.XMLUtils (localName, GIRXMLNamespace(..), + childElemsWithLocalName, childElemsWithNSName, + lookupAttr, lookupAttrWithNamespace) + +-- | Info to carry around when parsing. +data ParseContext = ParseContext { + ctxNamespace :: Text, + -- Location in the XML tree of the node being parsed (for + -- debugging purposes). + treePosition :: [Text], + -- Current element being parsed (to be set by withElement) + currentElement :: Element, + knownAliases :: M.Map Alias Type + } deriving Show + +-- | A message describing a parsing error in human readable form. +type ParseError = Text + +-- | Monad where parsers live: we carry a context around, and can +-- throw errors that abort the parsing. +type Parser a = ReaderT ParseContext (Except ParseError) a + +-- | Throw a parse error. +parseError :: ParseError -> Parser a +parseError msg = do + ctx <- ask + let position = (T.intercalate " / " . reverse . treePosition) ctx + throwError $ "Error when parsing \"" <> position <> "\": " <> msg <> "\n" + <> (T.pack . ppShow . currentElement) ctx + +-- | Build a textual description (for debug purposes) of a given element. +elementDescription :: Element -> Text +elementDescription element = + case M.lookup "name" (elementAttributes element) of + Nothing -> localName element + Just n -> localName element <> " [" <> n <> "]" + +-- | Build a name in the current namespace. +nameInCurrentNS :: Text -> Parser Name +nameInCurrentNS n = do + ctx <- ask + return $ Name (T.unpack (ctxNamespace ctx)) (T.unpack n) + +-- | Return the current namespace. +currentNamespace :: Parser Text +currentNamespace = ctxNamespace <$> ask + +-- | Check whether there is an alias for the given name, and return +-- the corresponding type in case it exists, and otherwise a TInterface. +resolveQualifiedTypeName :: Text -> Text -> Parser Type +resolveQualifiedTypeName ns n = do + ctx <- ask + case M.lookup (Alias (ns, n)) (knownAliases ctx) of + -- The resolved type may be an alias itself, like for + -- Gtk.Allocation -> Gdk.Rectangle -> cairo.RectangleInt + Just (TInterface ns n) -> resolveQualifiedTypeName (T.pack ns) (T.pack n) + Just t -> return t + Nothing -> return $ TInterface (T.unpack ns) (T.unpack n) + +-- | Return the value of an attribute for the given element. If the +-- attribute is not present this throws an error. +getAttr :: XML.Name -> Parser Text +getAttr attr = do + ctx <- ask + case lookupAttr attr (currentElement ctx) of + Just val -> return val + Nothing -> parseError $ "Expected attribute \"" <> + (T.pack . show) attr <> "\" not present." + +-- | Like 'getAttr', but allow for specifying the namespace. +getAttrWithNamespace :: GIRXMLNamespace -> XML.Name -> Parser Text +getAttrWithNamespace ns attr = do + ctx <- ask + case lookupAttrWithNamespace ns attr (currentElement ctx) of + Just val -> return val + Nothing -> parseError $ "Expected attribute \"" <> + (T.pack . show) attr <> "\" in namespace \"" <> + (T.pack . show) ns <> "\" not present." + +-- | Return the value of an attribute if it is present, and Nothing otherwise. +queryAttr :: XML.Name -> Parser (Maybe Text) +queryAttr attr = do + ctx <- ask + return $ lookupAttr attr (currentElement ctx) + +-- | Like `queryAttr`, but allow for specifying the namespace. +queryAttrWithNamespace :: GIRXMLNamespace -> XML.Name -> Parser (Maybe Text) +queryAttrWithNamespace ns attr = do + ctx <- ask + return $ lookupAttrWithNamespace ns attr (currentElement ctx) + +-- | Ask for an optional attribute, applying the given parser to +-- it. If the argument does not exist return the default value provided. +optionalAttr :: XML.Name -> a -> (Text -> Parser a) -> Parser a +optionalAttr attr def parser = + queryAttr attr >>= \case + Just a -> parser a + Nothing -> return def + +-- | Build a 'Name' out of the (possibly qualified) supplied name. If +-- the supplied name is unqualified we qualify with the current +-- namespace, and otherwise we simply parse it. +qualifyName :: Text -> Parser Name +qualifyName n = case T.split (== '.') n of + [ns, name] -> return $ Name (T.unpack ns) (T.unpack name) + [name] -> nameInCurrentNS name + _ -> parseError "Could not understand name" + +-- | Get the qualified name for the current element. +parseName :: Parser Name +parseName = getAttr "name" >>= qualifyName + +-- | Parse the deprecation text, if present. +parseDeprecation :: Parser (Maybe DeprecationInfo) +parseDeprecation = do + ctx <- ask + return $ queryDeprecated (currentElement ctx) + +-- | Parse a signed integral number. +parseIntegral :: Integral a => Text -> Parser a +parseIntegral str = + case TR.signed TR.decimal str of + Right (n, r) | T.null r -> return n + _ -> parseError $ "Could not parse integral value: \"" <> str <> "\"." + +-- | A boolean value given by a numerical constant. +parseBool :: Text -> Parser Bool +parseBool "0" = return False +parseBool "1" = return True +parseBool other = parseError $ "Unsupported boolean value: " <> T.pack (show other) + +-- | Parse all the introspectable subelements with the given local name. +parseChildrenWithLocalName :: Text -> Parser a -> Parser [a] +parseChildrenWithLocalName n parser = do + ctx <- ask + let introspectableChildren = filter introspectable + (childElemsWithLocalName n (currentElement ctx)) + mapM (withElement parser) introspectableChildren + where introspectable :: Element -> Bool + introspectable e = lookupAttr "introspectable" e /= Just "0" && + lookupAttr "shadowed-by" e == Nothing + +-- | Parse all subelements with the given local name. +parseAllChildrenWithLocalName :: Text -> Parser a -> Parser [a] +parseAllChildrenWithLocalName n parser = do + ctx <- ask + mapM (withElement parser) (childElemsWithLocalName n (currentElement ctx)) + +-- | Parse all introspectable children with the given namespace and +-- local name. +parseChildrenWithNSName :: GIRXMLNamespace -> Text -> Parser a -> Parser [a] +parseChildrenWithNSName ns n parser = do + ctx <- ask + let introspectableChildren = filter introspectable + (childElemsWithNSName ns n (currentElement ctx)) + mapM (withElement parser) introspectableChildren + where introspectable :: Element -> Bool + introspectable e = lookupAttr "introspectable" e /= Just "0" + +-- | Run the given parser for a given subelement in the XML tree. +withElement :: Parser a -> Element -> Parser a +withElement parser element = local modifyParsePosition parser + where modifyParsePosition ctx = + ctx { treePosition = elementDescription element : treePosition ctx + , currentElement = element} + +-- | Run the given parser, returning either success or an error. +runParser :: Text -> M.Map Alias Type -> Element -> Parser a -> + Either ParseError a +runParser ns aliases element parser = + runExcept (runReaderT parser ctx) + where ctx = ParseContext { + ctxNamespace = ns + , treePosition = [elementDescription element] + , currentElement = element + , knownAliases = aliases + } diff --git a/src/GI/GIR/Repository.hs b/src/GI/GIR/Repository.hs new file mode 100644 --- /dev/null +++ b/src/GI/GIR/Repository.hs @@ -0,0 +1,62 @@ +module GI.GIR.Repository (readGiRepository) where + +import Prelude hiding (readFile) + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative ((<$>)) +#endif + +import Control.Monad (when) +import Data.Maybe +import qualified Data.List as List +import qualified Data.Text as T +import Data.Text (Text) +import Safe (maximumMay) +import Text.XML + +import System.Directory +import System.Environment.XDG.BaseDir (getSystemDataDirs) +import System.FilePath + +girDataDirs :: IO [FilePath] +girDataDirs = getSystemDataDirs "gir-1.0" + +girFilePath :: String -> String -> FilePath -> FilePath +girFilePath name version path = path name ++ "-" ++ version <.> "gir" + +girFile' :: Text -> Maybe Text -> FilePath -> IO (Maybe FilePath) +girFile' name (Just version) path = + let filePath = girFilePath (T.unpack name) (T.unpack version) path + in doesFileExist filePath >>= \case + True -> return $ Just filePath + False -> return Nothing +girFile' name Nothing path = + doesDirectoryExist path >>= \case + True -> do + repositories <- map takeBaseName <$> getDirectoryContents path + let version = maximumMay . catMaybes $ + List.stripPrefix (T.unpack name ++ "-") <$> repositories + + return $ case version of + Just v -> Just $ girFilePath (T.unpack name) v path + Nothing -> Nothing + + False -> return Nothing + +girFile :: Text -> Maybe Text -> [FilePath] -> IO (Maybe FilePath) +girFile name version extraPaths = do + dataDirs <- girDataDirs + firstJust <$> (mapM (girFile' name version) (extraPaths ++ dataDirs)) + where firstJust = listToMaybe . catMaybes + +readGiRepository :: Bool -> Text -> Maybe Text -> [FilePath] -> IO Document +readGiRepository verbose name version extraPaths = + girFile name version extraPaths >>= \case + Just path -> do + when verbose $ putStrLn $ "Loading GI repository: " ++ path + readFile def path + Nothing -> do + dataDirs <- girDataDirs + error $ "Did not find a GI repository for " ++ (T.unpack name) + ++ maybe "" ("-" ++) (T.unpack <$> version) + ++ " in " ++ show dataDirs diff --git a/src/GI/GIR/Signal.hs b/src/GI/GIR/Signal.hs new file mode 100644 --- /dev/null +++ b/src/GI/GIR/Signal.hs @@ -0,0 +1,26 @@ +module GI.GIR.Signal + ( Signal(..) + , parseSignal + ) where + +import Data.Text (Text) + +import GI.GIR.Callable (Callable(..), parseCallable) +import GI.GIR.Parser + +data Signal = Signal { + sigName :: Text, + sigCallable :: Callable, + sigDeprecated :: Maybe DeprecationInfo + } deriving (Show, Eq) + +parseSignal :: Parser Signal +parseSignal = do + n <- getAttr "name" + deprecated <- parseDeprecation + callable <- parseCallable + return $ Signal { + sigName = n + , sigCallable = callable + , sigDeprecated = deprecated + } diff --git a/src/GI/GIR/Struct.hs b/src/GI/GIR/Struct.hs new file mode 100644 --- /dev/null +++ b/src/GI/GIR/Struct.hs @@ -0,0 +1,47 @@ +-- | Parsing of structs. +module GI.GIR.Struct + ( Struct(..) + , parseStruct + ) where + +import Data.Text (Text) + +import GI.GIR.Field (Field, parseFields) +import GI.GIR.Method (Method, MethodType(..), parseMethod) +import GI.GIR.Parser + +data Struct = Struct { + structIsBoxed :: Bool, + structTypeInit :: Maybe Text, + structSize :: Int, + gtypeStructFor :: Maybe Name, + -- https://bugzilla.gnome.org/show_bug.cgi?id=560248 + structIsDisguised :: Bool, + structFields :: [Field], + structMethods :: [(Name, Method)], + structDeprecated :: Maybe DeprecationInfo } + deriving Show + +parseStruct :: Parser (Name, Struct) +parseStruct = do + name <- parseName + deprecated <- parseDeprecation + structFor <- queryAttrWithNamespace GLibGIRNS "is-gtype-struct-for" >>= \case + Just t -> (fmap Just . qualifyName) t + Nothing -> return Nothing + typeInit <- queryAttrWithNamespace GLibGIRNS "get-type" + disguised <- optionalAttr "disguised" False parseBool + fields <- parseFields + constructors <- parseChildrenWithLocalName "constructor" (parseMethod Constructor) + methods <- parseChildrenWithLocalName "method" (parseMethod OrdinaryMethod) + return (name, + Struct { + structIsBoxed = error ("[boxed] unfixed struct " ++ show name) + , structTypeInit = typeInit + , structSize = error ("[size] unfixed struct " ++ show name) + , gtypeStructFor = structFor + , structIsDisguised = disguised + , structFields = fields + , structMethods = constructors ++ methods + , structDeprecated = deprecated + }) diff --git a/src/GI/GIR/Type.hs b/src/GI/GIR/Type.hs new file mode 100644 --- /dev/null +++ b/src/GI/GIR/Type.hs @@ -0,0 +1,162 @@ +{-# LANGUAGE RecordWildCards, PatternGuards #-} +-- | Parsing type information from GIR files. +module GI.GIR.Type + ( parseType + ) where + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative ((<$>), (<*>)) +#endif + +import Data.Monoid ((<>)) +import Data.Text (Text) +import qualified Data.Text as T +import Foreign.Storable (sizeOf) +import Foreign.C (CShort, CUShort, CInt, CUInt, CLong, CULong, CSize) +import System.Posix.Types (CSsize) + +import GI.Type (Type(..), BasicType(..)) +import GI.GIR.Parser + +-- | Map the given type name to a BasicType (in GI.Type), if possible. +nameToBasicType :: Text -> Maybe BasicType +nameToBasicType "none" = Just TVoid +-- XXX Should we try to distinguish TPtr from TVoid? +nameToBasicType "gpointer" = Just TVoid +nameToBasicType "gboolean" = Just TBoolean +nameToBasicType "gchar" = Just TInt8 +nameToBasicType "gint8" = Just TInt8 +nameToBasicType "guint8" = Just TUInt8 +nameToBasicType "gint16" = Just TInt16 +nameToBasicType "guint16" = Just TUInt16 +nameToBasicType "gint32" = Just TInt32 +nameToBasicType "guint32" = Just TUInt32 +nameToBasicType "gint64" = Just TInt64 +nameToBasicType "guint64" = Just TUInt64 +nameToBasicType "gfloat" = Just TFloat +nameToBasicType "gdouble" = Just TDouble +nameToBasicType "gunichar" = Just TUniChar +nameToBasicType "GType" = Just TGType +nameToBasicType "utf8" = Just TUTF8 +nameToBasicType "filename" = Just TFileName +nameToBasicType "gshort" = case sizeOf (0 :: CShort) of + 2 -> Just TInt16 + 4 -> Just TInt32 + 8 -> Just TInt64 + n -> error $ "Unexpected short size: " ++ show n +nameToBasicType "gushort" = case sizeOf (0 :: CUShort) of + 2 -> Just TUInt16 + 4 -> Just TUInt32 + 8 -> Just TUInt64 + n -> error $ "Unexpected ushort size: " ++ show n +nameToBasicType "gint" = case sizeOf (0 :: CInt) of + 4 -> Just TInt32 + 8 -> Just TInt64 + n -> error $ "Unexpected int length: " ++ show n +nameToBasicType "guint" = case sizeOf (0 :: CUInt) of + 4 -> Just TUInt32 + 8 -> Just TUInt64 + n -> error $ "Unexpected uint length: " ++ show n +nameToBasicType "glong" = case sizeOf (0 :: CLong) of + 4 -> Just TInt32 + 8 -> Just TInt64 + n -> error $ "Unexpected long length: " ++ show n +nameToBasicType "gulong" = case sizeOf (0 :: CULong) of + 4 -> Just TUInt32 + 8 -> Just TUInt64 + n -> error $ "Unexpected ulong length: " ++ show n +nameToBasicType "gssize" = case sizeOf (0 :: CSsize) of + 4 -> Just TInt32 + 8 -> Just TInt64 + n -> error $ "Unexpected ssize length: " ++ show n +nameToBasicType "gsize" = case sizeOf (0 :: CSize) of + 4 -> Just TUInt32 + 8 -> Just TUInt64 + n -> error $ "Unexpected size length: " ++ show n +nameToBasicType _ = Nothing + +-- | The different array types. +parseArrayInfo :: Parser Type +parseArrayInfo = queryAttr "name" >>= \case + Just "GLib.Array" -> TGArray <$> parseType + Just "GLib.PtrArray" -> TPtrArray <$> parseType + Just "GLib.ByteArray" -> return TByteArray + Just other -> parseError $ "Unsupported array type: \"" <> other <> "\"" + Nothing -> parseCArrayType + +-- | A C array +parseCArrayType :: Parser Type +parseCArrayType = do + zeroTerminated <- queryAttr "zero-terminated" >>= \case + Just b -> parseBool b + Nothing -> return True + length <- queryAttr "length" >>= \case + Just l -> parseIntegral l + Nothing -> return (-1) + fixedSize <- queryAttr "fixed-size" >>= \case + Just s -> parseIntegral s + Nothing -> return (-1) + elementType <- parseType + return $ TCArray zeroTerminated fixedSize length elementType + +-- | A hash table. +parseHashTable :: Parser Type +parseHashTable = parseTypeElements >>= \case + [key, value] -> return $ TGHash key value + other -> parseError $ "Unsupported hash type: " + <> T.pack (show other) + +-- | For GLists and GSLists there is sometimes no information about +-- the type of the elements. In these cases we report them as +-- pointers. +parseListType :: Parser Type +parseListType = queryType >>= \case + Just t -> return t + Nothing -> return (TBasicType TVoid) + +-- | A type which is not a BasicType or array. +parseFundamentalType :: Text -> Text -> Parser Type +parseFundamentalType "GLib" "List" = TGList <$> parseListType +parseFundamentalType "GLib" "SList" = TGSList <$> parseListType +parseFundamentalType "GLib" "HashTable" = parseHashTable +parseFundamentalType "GLib" "Error" = return TError +parseFundamentalType "GLib" "Variant" = return TVariant +parseFundamentalType "GObject" "ParamSpec" = return TParamSpec +-- A TInterface type (basically, everything that is not of a known type). +parseFundamentalType ns n = resolveQualifiedTypeName ns n + +-- | Parse information on a "type" element. +parseTypeInfo :: Parser Type +parseTypeInfo = do + typeName <- getAttr "name" + case nameToBasicType typeName of + Just b -> return (TBasicType b) + Nothing -> case T.split ('.' ==) typeName of + [ns, n] -> parseFundamentalType ns n + [n] -> do + ns <- currentNamespace + parseFundamentalType ns n + _ -> parseError $ "Unsupported type form: \"" + <> typeName <> "\"" + +-- | Find the children giving the type of the given element. +parseTypeElements :: Parser [Type] +parseTypeElements = (++) <$> parseChildrenWithLocalName "type" parseTypeInfo <*> + parseChildrenWithLocalName "array" parseArrayInfo + +-- | Try to find a type node, but do not error out if it is not +-- found. This _does_ give an error if more than one type node is +-- found. +queryType :: Parser (Maybe Type) +queryType = parseTypeElements >>= \case + [e] -> return (Just e) + [] -> return Nothing + _ -> parseError $ "Found more than one type for the element." + +-- | Parse the type of a node (which will be described by a child node +-- named "type" or "array"). +parseType :: Parser Type +parseType = parseTypeElements >>= \case + [e] -> return e + [] -> parseError $ "Did not find a type for the element." + _ -> parseError $ "Found more than one type for the element." diff --git a/src/GI/GIR/Union.hs b/src/GI/GIR/Union.hs new file mode 100644 --- /dev/null +++ b/src/GI/GIR/Union.hs @@ -0,0 +1,40 @@ +-- | Parsing of unions. +module GI.GIR.Union + ( Union(..) + , parseUnion + ) where + +import Data.Maybe (isJust) +import Data.Text (Text) + +import GI.GIR.Field (Field, parseFields) +import GI.GIR.Method (Method, MethodType(..), parseMethod) +import GI.GIR.Parser + +data Union = Union { + unionIsBoxed :: Bool, + unionSize :: Int, + unionTypeInit :: Maybe Text, + unionFields :: [Field], + unionMethods :: [(Name, Method)], + unionDeprecated :: Maybe DeprecationInfo } + deriving Show + +parseUnion :: Parser (Name, Union) +parseUnion = do + name <- parseName + deprecated <- parseDeprecation + typeInit <- queryAttrWithNamespace GLibGIRNS "get-type" + fields <- parseFields + constructors <- parseChildrenWithLocalName "constructor" (parseMethod Constructor) + methods <- parseChildrenWithLocalName "method" (parseMethod OrdinaryMethod) + return (name, + Union { + unionIsBoxed = isJust typeInit + , unionTypeInit = typeInit + , unionSize = error ("unfixed union size " ++ show name) + , unionFields = fields + , unionMethods = constructors ++ methods + , unionDeprecated = deprecated + }) + diff --git a/src/GI/GIR/XMLUtils.hs b/src/GI/GIR/XMLUtils.hs new file mode 100644 --- /dev/null +++ b/src/GI/GIR/XMLUtils.hs @@ -0,0 +1,79 @@ +-- | Some helpers for making traversals of GIR documents easier. +module GI.GIR.XMLUtils + ( nodeToElement + , subelements + , localName + , lookupAttr + , GIRXMLNamespace(..) + , lookupAttrWithNamespace + , childElemsWithLocalName + , childElemsWithNSName + , firstChildWithLocalName + , getElementContent + ) where + +import Text.XML (Element(elementNodes, elementName, elementAttributes), + Node(NodeContent, NodeElement), nameLocalName, Name(..)) +import Data.Maybe (mapMaybe, listToMaybe) +import qualified Data.Map as M +import Data.Text (Text) + +-- | Turn a node into an element (if it is indeed an element node). +nodeToElement :: Node -> Maybe Element +nodeToElement (NodeElement e) = Just e +nodeToElement _ = Nothing + +-- | Find all children of the given element which are XML Elements +-- themselves. +subelements :: Element -> [Element] +subelements = mapMaybe nodeToElement . elementNodes + +-- | The local name of an element. +localName :: Element -> Text +localName = nameLocalName . elementName + +-- | Restrict to those with the given local name. +childElemsWithLocalName :: Text -> Element -> [Element] +childElemsWithLocalName n = + filter localNameMatch . subelements + where localNameMatch = (== n) . localName + +-- | Restrict to those with given name. +childElemsWithNSName :: GIRXMLNamespace -> Text -> Element -> [Element] +childElemsWithNSName ns n = filter nameMatch . subelements + where nameMatch = (== name) . elementName + name = Name { + nameLocalName = n + , nameNamespace = Just (girNamespace ns) + , namePrefix = Nothing + } + +-- | Find the first child element with the given name. +firstChildWithLocalName :: Text -> Element -> Maybe Element +firstChildWithLocalName n = listToMaybe . childElemsWithLocalName n + +-- | Get the content of a given element, if it exists. +getElementContent :: Element -> Maybe Text +getElementContent = listToMaybe . mapMaybe getContent . elementNodes + where getContent :: Node -> Maybe Text + getContent (NodeContent t) = Just t + getContent _ = Nothing + +-- | Lookup an attribute for an element (with no prefix). +lookupAttr :: Name -> Element -> Maybe Text +lookupAttr attr element = M.lookup attr (elementAttributes element) + +-- | GIR namespaces we know about. +data GIRXMLNamespace = GLibGIRNS | CGIRNS + deriving Show + +-- | Return the text representation of the known GIR namespaces. +girNamespace :: GIRXMLNamespace -> Text +girNamespace GLibGIRNS = "http://www.gtk.org/introspection/glib/1.0" +girNamespace CGIRNS = "http://www.gtk.org/introspection/c/1.0" + +-- | Lookup an attribute for an element, given the namespace where it lives. +lookupAttrWithNamespace :: GIRXMLNamespace -> Name -> Element -> Maybe Text +lookupAttrWithNamespace ns attr element = + let attr' = attr {nameNamespace = Just (girNamespace ns)} + in M.lookup attr' (elementAttributes element) diff --git a/src/GI/GObject.hs b/src/GI/GObject.hs new file mode 100644 --- /dev/null +++ b/src/GI/GObject.hs @@ -0,0 +1,52 @@ +module GI.GObject + ( isGObject + , apiIsGObject + , nameIsGObject + , isInitiallyUnowned + , apiIsInitiallyUnowned + ) where + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative ((<$>)) +#endif + +import GI.API +import GI.Code +import GI.Type + +-- Returns whether the given type is a descendant of the given parent. +typeDoParentSearch :: Name -> Type -> CodeGen Bool +typeDoParentSearch parent (TInterface ns n) = findAPIByName name >>= + apiDoParentSearch parent name + where name = Name ns n +typeDoParentSearch _ _ = return False + +apiDoParentSearch :: Name -> Name -> API -> CodeGen Bool +apiDoParentSearch parent n api + | parent == n = return True + | otherwise = case api of + APIObject o -> + case objParent o of + Just (Name pns pn) -> typeDoParentSearch parent (TInterface pns pn) + Nothing -> return False + APIInterface iface -> + do let prs = ifPrerequisites iface + prereqs <- zip prs <$> mapM findAPIByName prs + or <$> mapM (uncurry (apiDoParentSearch parent)) prereqs + _ -> return False + +isGObject :: Type -> CodeGen Bool +isGObject = typeDoParentSearch $ Name "GObject" "Object" + +-- | Check whether the given name descends from GObject. +nameIsGObject :: Name -> CodeGen Bool +nameIsGObject n = findAPIByName n >>= apiIsGObject n + +apiIsGObject :: Name -> API -> CodeGen Bool +apiIsGObject = apiDoParentSearch $ Name "GObject" "Object" + +isInitiallyUnowned :: Type -> CodeGen Bool +isInitiallyUnowned = typeDoParentSearch $ Name "GObject" "InitiallyUnowned" + +apiIsInitiallyUnowned :: Name -> API -> CodeGen Bool +apiIsInitiallyUnowned = apiDoParentSearch $ Name "GObject" "InitiallyUnowned" diff --git a/src/GI/GType.hsc b/src/GI/GType.hsc new file mode 100644 --- /dev/null +++ b/src/GI/GType.hsc @@ -0,0 +1,24 @@ +module GI.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 diff --git a/src/GI/Inheritance.hs b/src/GI/Inheritance.hs new file mode 100644 --- /dev/null +++ b/src/GI/Inheritance.hs @@ -0,0 +1,142 @@ +{-# LANGUAGE ScopedTypeVariables #-} +module GI.Inheritance + ( fullObjectPropertyList + , fullInterfacePropertyList + , fullObjectSignalList + , fullInterfaceSignalList + , instanceTree + ) where + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative ((<$>), (<*>)) +#endif +import Control.Monad (foldM) +import qualified Data.Map as M +import Data.Text (Text) + +import GI.API +import GI.Code (findAPIByName, CodeGen, line) + +-- | Find the parent of a given object when building the +-- instanceTree. For the purposes of the binding we do not need to +-- distinguish between GObject.Object and GObject.InitiallyUnowned. +getParent :: API -> Maybe Name +getParent (APIObject o) = rename $ objParent o + where + rename :: Maybe Name -> Maybe Name + rename (Just (Name "GObject" "InitiallyUnowned")) = + Just (Name "GObject" "Object") + rename x = x +getParent _ = Nothing + +-- | Compute the (ordered) list of parents of the current object. +instanceTree :: Name -> CodeGen [Name] +instanceTree n = do + api <- findAPIByName n + case getParent api of + Just p -> (p :) <$> instanceTree p + Nothing -> return [] + +-- A class for qualities of an object/interface that it inherits from +-- its ancestors. Properties and Signals are two classes of interest. +class Inheritable i where + ifInheritables :: Interface -> [i] + objInheritables :: Object -> [i] + iName :: i -> Text + +instance Inheritable Property where + ifInheritables = ifProperties + objInheritables = objProperties + iName = propName + +instance Inheritable Signal where + ifInheritables = ifSignals + objInheritables = objSignals + iName = sigName + +-- Returns a list of all inheritables defined for this object +-- (including those defined by its ancestors and the interfaces it +-- implements), together with the name of the interface defining the +-- property. +apiInheritables :: Inheritable i => Name -> CodeGen [(Name, i)] +apiInheritables n = do + api <- findAPIByName n + case api of + APIInterface iface -> return $ map ((,) n) (ifInheritables iface) + APIObject object -> return $ map ((,) n) (objInheritables object) + _ -> error $ "apiInheritables : Unexpected API : " ++ show n + +fullAPIInheritableList :: Inheritable i => Name -> CodeGen [(Name, i)] +fullAPIInheritableList n = do + api <- findAPIByName n + case api of + APIInterface iface -> fullInterfaceInheritableList n iface + APIObject object -> fullObjectInheritableList n object + _ -> error $ "FullAPIInheritableList : Unexpected API : " ++ show n + +fullObjectInheritableList :: Inheritable i => Name -> Object -> + CodeGen [(Name, i)] +fullObjectInheritableList n obj = do + iT <- instanceTree n + (++) <$> (concat <$> mapM apiInheritables (n : iT)) + <*> (concat <$> mapM apiInheritables (objInterfaces obj)) + +fullInterfaceInheritableList :: Inheritable i => Name -> Interface -> + CodeGen [(Name, i)] +fullInterfaceInheritableList n iface = + (++) (map ((,) n) (ifInheritables iface)) + <$> (concat <$> mapM fullAPIInheritableList (ifPrerequisites iface)) + +-- It is sometimes the case that a property name or signal is defined +-- both in an object and in one of its ancestors/implemented +-- interfaces. This is harmless if the properties are isomorphic +-- (there will be more than one qualified set of property +-- setters/getters that we can call, but they are all isomorphic). If +-- they are not isomorphic we refuse to set either, and print a +-- warning in the generated code. +removeDuplicates :: forall i. (Eq i, Show i, Inheritable i) => + [(Name, i)] -> CodeGen [(Name, i)] +removeDuplicates inheritables = + (filterTainted . M.toList) <$> foldM filterDups M.empty inheritables + where + filterDups :: M.Map Text (Bool, Name, i) -> (Name, i) -> + CodeGen (M.Map Text (Bool, Name, i)) + filterDups m (name, prop) = + case M.lookup (iName prop) m of + Just (tainted, n, p) + | tainted -> return m + | (p == prop) -> return m -- Duplicated, but isomorphic property + | otherwise -> + do line "--- XXX Duplicated object with different types:" + line $ " --- " ++ show n ++ " -> " ++ show p + line $ " --- " ++ show name ++ " -> " ++ show prop + -- Tainted + return $ M.insert (iName prop) (True, n, p) m + Nothing -> return $ M.insert (iName prop) (False, name, prop) m + filterTainted :: [(Text, (Bool, Name, i))] -> [(Name, i)] + filterTainted xs = + [(name, prop) | (_, (tainted, name, prop)) <- xs, not tainted] + +-- | List all properties defined for an object, including those +-- defined by its ancestors. +fullObjectPropertyList :: Name -> Object -> CodeGen [(Name, Property)] +fullObjectPropertyList n o = fullObjectInheritableList n o >>= + removeDuplicates + +-- | List all properties defined for an interface, including those +-- defined by its prerequisites. +fullInterfacePropertyList :: Name -> Interface -> CodeGen [(Name, Property)] +fullInterfacePropertyList n i = fullInterfaceInheritableList n i >>= + removeDuplicates + +-- | List all signals defined for an object, including those +-- defined by its ancestors. +fullObjectSignalList :: Name -> Object -> CodeGen [(Name, Signal)] +fullObjectSignalList n o = fullObjectInheritableList n o >>= + removeDuplicates + +-- | List all signals defined for an interface, including those +-- defined by its prerequisites. +fullInterfaceSignalList :: Name -> Interface -> CodeGen [(Name, Signal)] +fullInterfaceSignalList n i = fullInterfaceInheritableList n i >>= + removeDuplicates diff --git a/src/GI/LibGIRepository.hs b/src/GI/LibGIRepository.hs new file mode 100644 --- /dev/null +++ b/src/GI/LibGIRepository.hs @@ -0,0 +1,150 @@ +{-# LANGUAGE ScopedTypeVariables #-} +-- | A minimal wrapper for libgirepository. +module GI.LibGIRepository + ( girRequire + , girStructSizeAndOffsets + , girUnionSizeAndOffsets + , girLoadGType + ) where + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative ((<$>)) +#endif + +import Control.Monad (forM, when) +import qualified Data.Map as M +import Data.Text (Text) +import qualified Data.Text as T + +import Foreign.C.Types (CInt(..), CSize(..)) +import Foreign.C.String (CString) +import Foreign (nullPtr, Ptr, ForeignPtr, FunPtr, peek) + +import Data.GI.Base.BasicConversions (withTextCString, cstringToText) +import Data.GI.Base.BasicTypes (BoxedObject(..), GType(..), CGType) +import Data.GI.Base.GError (GError, checkGError) +import Data.GI.Base.ManagedPtr (wrapBoxed, withManagedPtr) +import Data.GI.Base.Utils (allocMem, freeMem) + +-- | Wrapper for 'GIBaseInfo' +newtype BaseInfo = BaseInfo (ForeignPtr BaseInfo) + +-- | Wrapper for 'GITypelib' +newtype Typelib = Typelib (Ptr Typelib) + +foreign import ccall "g_base_info_gtype_get_type" c_g_base_info_gtype_get_type :: IO GType + +instance BoxedObject BaseInfo where + boxedType _ = c_g_base_info_gtype_get_type + +foreign import ccall "g_irepository_require" g_irepository_require :: + Ptr () -> CString -> CString -> CInt -> Ptr (Ptr GError) + -> IO (Ptr Typelib) + +-- | Ensure that the given version of the namespace is loaded. If that +-- is not possible we error out. +girRequire :: Text -> Text -> IO Typelib +girRequire ns version = + withTextCString ns $ \cns -> + withTextCString version $ \cversion -> do + typelib <- checkGError (g_irepository_require nullPtr cns cversion 0) + (error $ "Could not load typelib for " + ++ show ns ++ " version " + ++ show version) + return (Typelib typelib) + +foreign import ccall "g_irepository_find_by_name" g_irepository_find_by_name :: + Ptr () -> CString -> CString -> IO (Ptr BaseInfo) + +-- | Find a given baseinfo by name, or give an error if it cannot be +-- found. +girFindByName :: Text -> Text -> IO BaseInfo +girFindByName ns name = + withTextCString ns $ \cns -> + withTextCString name $ \cname -> do + ptr <- g_irepository_find_by_name nullPtr cns cname + if ptr == nullPtr + then error ("Could not find " ++ T.unpack ns ++ "::" ++ T.unpack name) + else wrapBoxed BaseInfo ptr + +foreign import ccall "g_field_info_get_offset" g_field_info_get_offset :: + Ptr BaseInfo -> IO CInt +foreign import ccall "g_base_info_get_name" g_base_info_get_name :: + Ptr BaseInfo -> IO CString + +foreign import ccall "g_struct_info_get_size" g_struct_info_get_size :: + Ptr BaseInfo -> IO CSize +foreign import ccall "g_struct_info_get_n_fields" g_struct_info_get_n_fields :: + Ptr BaseInfo -> IO CInt +foreign import ccall "g_struct_info_get_field" g_struct_info_get_field :: + Ptr BaseInfo -> CInt -> IO (Ptr BaseInfo) + +-- | Find out the size of a struct, and the map from field names to +-- offsets inside the struct. +girStructSizeAndOffsets :: Text -> Text -> IO (Int, M.Map Text Int) +girStructSizeAndOffsets ns name = do + baseinfo <- girFindByName ns name + withManagedPtr baseinfo $ \si -> do + size <- g_struct_info_get_size si + nfields <- g_struct_info_get_n_fields si + fieldOffsets <- forM [0..(nfields-1)] $ \i -> do + fieldInfo <- (g_struct_info_get_field si i + >>= wrapBoxed BaseInfo) + withManagedPtr fieldInfo $ \fi -> do + fname <- (g_base_info_get_name fi >>= cstringToText) + fOffset <- g_field_info_get_offset fi + return (fname, fromIntegral fOffset) + return (fromIntegral size, M.fromList fieldOffsets) + +foreign import ccall "g_union_info_get_size" g_union_info_get_size :: + Ptr BaseInfo -> IO CSize +foreign import ccall "g_union_info_get_n_fields" g_union_info_get_n_fields :: + Ptr BaseInfo -> IO CInt +foreign import ccall "g_union_info_get_field" g_union_info_get_field :: + Ptr BaseInfo -> CInt -> IO (Ptr BaseInfo) + +-- | Find out the size of a union, and the map from field names to +-- offsets inside the union. +girUnionSizeAndOffsets :: Text -> Text -> IO (Int, M.Map Text Int) +girUnionSizeAndOffsets ns name = do + baseinfo <- girFindByName ns name + withManagedPtr baseinfo $ \ui -> do + size <- g_union_info_get_size ui + nfields <- g_union_info_get_n_fields ui + fieldOffsets <- forM [0..(nfields-1)] $ \i -> do + fieldInfo <- (g_union_info_get_field ui i + >>= wrapBoxed BaseInfo) + withManagedPtr fieldInfo $ \fi -> do + fname <- (g_base_info_get_name fi >>= cstringToText) + fOffset <- g_field_info_get_offset fi + return (fname, fromIntegral fOffset) + return (fromIntegral size, M.fromList fieldOffsets) + +foreign import ccall "g_typelib_symbol" g_typelib_symbol :: + Ptr Typelib -> CString -> Ptr (FunPtr a) -> IO CInt + +-- | Load a symbol from the dynamic library associated to the given namespace. +girSymbol :: forall a. Text -> Text -> IO (FunPtr a) +girSymbol ns symbol = do + typelib <- withTextCString ns $ \cns -> + checkGError (g_irepository_require nullPtr cns nullPtr 0) + (error $ "Could not load typelib " ++ show ns) + funPtrPtr <- allocMem :: IO (Ptr (FunPtr a)) + result <- withTextCString symbol $ \csymbol -> + g_typelib_symbol typelib csymbol funPtrPtr + when (result /= 1) $ + error ("Could not resolve symbol " ++ show symbol ++ " in namespace " + ++ show ns) + funPtr <- peek funPtrPtr + freeMem funPtrPtr + return funPtr + +type GTypeInit = IO CGType +foreign import ccall "dynamic" gtypeInit :: FunPtr GTypeInit -> GTypeInit + +-- | Load a GType given the namespace where it lives and the type init +-- function. +girLoadGType :: Text -> Text -> IO GType +girLoadGType ns typeInit = do + funPtr <- girSymbol ns typeInit + GType <$> gtypeInit funPtr diff --git a/src/GI/OverloadedSignals.hs b/src/GI/OverloadedSignals.hs new file mode 100644 --- /dev/null +++ b/src/GI/OverloadedSignals.hs @@ -0,0 +1,171 @@ +module GI.OverloadedSignals + ( genSignalInstances + , genOverloadedSignalConnectors + ) where + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative ((<$>)) +#endif +import Control.Monad (forM_, when) +import Control.Monad.Writer (tell) +import Data.Text (Text) +import qualified Data.Text as T + +import Data.List (intercalate) +import qualified Data.Set as S + +import GI.API +import GI.Code +import GI.Inheritance (fullObjectSignalList, fullInterfaceSignalList) +import GI.GObject (apiIsGObject) +import GI.Signal (signalHaskellName) +import GI.SymbolNaming (ucFirst, upperName) +import GI.Util (padTo) + +-- A list of distinct signal names for all GObjects appearing in the +-- given list of APIs. +findSignalNames :: [(Name, API)] -> CodeGen [String] +findSignalNames apis = (map T.unpack . S.toList) <$> go apis S.empty + where + go :: [(Name, API)] -> S.Set Text -> CodeGen (S.Set Text) + go [] set = return set + go ((_, api):apis) set = + case api of + APIInterface iface -> + go apis $ insertSignals (ifSignals iface) set + APIObject object -> + go apis $ insertSignals (objSignals object) set + _ -> go apis set + + insertSignals :: [Signal] -> S.Set Text -> S.Set Text + insertSignals props set = foldr (S.insert . sigName) set props + +-- | Generate the overloaded signal connectors: "Clicked", "ActivateLink", ... +genOverloadedSignalConnectors :: [(Name, API)] -> String -> CodeGen () +genOverloadedSignalConnectors allAPIs modulePrefix = do + line "-- Generated code." + blank + line "{-# LANGUAGE DataKinds, GADTs, KindSignatures, FlexibleInstances #-}" + blank + line $ "module " ++ modulePrefix ++ "Signals where" + blank + line "import GHC.TypeLits" + line "import GHC.Exts (Constraint)" + blank + line "class NoConstraint a" + line "instance NoConstraint a" + blank + line "data SignalProxy (a :: Symbol) (b :: Symbol) (c :: * -> Constraint) where" + indent $ do + signalNames <- findSignalNames allAPIs + let maxLength = maximum $ map (length . signalHaskellName) signalNames + forM_ signalNames $ \sn -> + line $ padTo (maxLength + 1) (ucFirst (signalHaskellName sn)) ++ + ":: SignalProxy \"" ++ sn ++ "\" \"\" NoConstraint" + +-- | Qualified name for the "(sigName, info)" tag for a given signal. +signalInfoName :: Name -> Signal -> CodeGen String +signalInfoName n signal = do + n' <- upperName n + return $ n' ++ (ucFirst . signalHaskellName . T.unpack . sigName) signal + ++ "SignalInfo" + +-- | Generate the given signal instance for the given API object. +genInstance :: Name -> Signal -> CodeGen () +genInstance owner signal = group $ do + name <- upperName owner + let sn = (ucFirst . signalHaskellName . T.unpack . sigName) signal + si <- signalInfoName owner signal + line $ "data " ++ si + line $ "instance SignalInfo " ++ si ++ " where" + indent $ do + let signalConnectorName = name ++ sn + cbHaskellType = signalConnectorName ++ "Callback" + line $ "type HaskellCallbackType " ++ si ++ " = " ++ cbHaskellType + line $ "connectSignal _ = " ++ "connect" ++ name ++ sn + +-- | Signal instances for (GObject-derived) objects. +genObjectSignals :: Name -> Object -> CodeGen () +genObjectSignals n o = do + name <- upperName n + isGO <- apiIsGObject n (APIObject o) + when isGO $ do + mapM_ (genInstance n) (objSignals o) + infos <- fullObjectSignalList n o >>= + mapM (\(owner, signal) -> do + si <- signalInfoName owner signal + return $ "'(\"" ++ (T.unpack . sigName) signal + ++ "\", " ++ si ++ ")") + -- The "notify::[property]" signal is a generic signal used for + -- connecting to property notifications. + let allSignals = infos ++ + ["'(\"notify::[property]\", GObjectNotifySignalInfo)"] + group . line $ "type instance SignalList " ++ name ++ + " = '[ " ++ intercalate ", " allSignals ++ "]" + +-- | Signal instances for interfaces. +genInterfaceSignals :: Name -> Interface -> CodeGen () +genInterfaceSignals n iface = do + name <- upperName n + mapM_ (genInstance n) (ifSignals iface) + infos <- fullInterfaceSignalList n iface >>= + mapM (\(owner, signal) -> do + si <- signalInfoName owner signal + return $ "'(\"" ++ T.unpack (sigName signal) + ++ "\", " ++ si ++ ")") + isGO <- apiIsGObject n (APIInterface iface) + -- The "notify::[property]" signal is a generic signal used for + -- connecting to property notifications of a GObject. + let allSignals = + if isGO + then infos ++ ["'(\"notify::[property]\", GObjectNotifySignalInfo)"] + else infos + group . line $ "type instance SignalList " ++ name ++ + " = '[ " ++ intercalate ", " allSignals ++ "]" + +-- | Generate HasSignal instances for a given API element. +genSignals :: (Name, API) -> CodeGen () +genSignals (n, APIObject o) = genObjectSignals n o +genSignals (n, APIInterface i) = genInterfaceSignals n i +genSignals _ = return () + +-- | Generate the signal information instances, so the generic overloaded +-- signal connectors are available. +genSignalInstances :: String -> [(Name, API)] -> String -> CodeGen () +genSignalInstances name apis modulePrefix = do + let mp = (modulePrefix ++) + nm = ucFirst name + + code <- recurse' $ forM_ apis genSignals + + line "-- Generated code." + blank + + -- Providing orphan instances is the whole point of these modules, + -- tell GHC that this is fine. + line "{-# OPTIONS_GHC -fno-warn-orphans #-}" + blank + line "{-# LANGUAGE DataKinds, FlexibleInstances," + line " TypeFamilies, MultiParamTypeClasses," + line " TypeOperators #-}" + blank + + line $ "module " ++ mp nm ++ "Signals where" + blank + + line "import Data.GI.Base.Properties (GObjectNotifySignalInfo)" + line "import Data.GI.Base.Signals" + line "import Data.GI.Base.Overloading" + blank + + -- Import dependencies, including instances for their overloaded + -- signals, so they are implicitly reexported and they do not need + -- to be included explicitly from client code. + deps <- S.toList <$> getDeps + forM_ deps $ \i -> when (i /= name) $ + line $ "import qualified " ++ mp (ucFirst i) ++ "Signals as " ++ ucFirst i + + line $ "import " ++ modulePrefix ++ nm + blank + + tell code diff --git a/src/GI/Overrides.hs b/src/GI/Overrides.hs new file mode 100644 --- /dev/null +++ b/src/GI/Overrides.hs @@ -0,0 +1,199 @@ +{-# LANGUAGE ViewPatterns #-} +module GI.Overrides + ( Overrides(pkgConfigMap, cabalPkgVersion, nsChooseVersion) + , parseOverridesFile + , filterAPIsAndDeps + ) where + +import Control.Monad.Except +import Control.Monad.State +import Control.Monad.Writer + +import Data.Maybe (fromMaybe, isJust) +import qualified Data.Map as M +import qualified Data.Set as S +import qualified Data.Text as T +import Data.Text (Text) + +import GI.API + +data Overrides = Overrides { + -- | Prefix for constants in a given namespace, if not given the + -- "_" string will be used. + constantPrefix :: M.Map String String, + -- | Ignored elements of a given API. + ignoredElems :: M.Map Name (S.Set Text), + -- | Ignored APIs (all elements in this API will just be discarded). + ignoredAPIs :: S.Set Name, + -- | Structs for which accessors should not be auto-generated. + sealedStructs :: S.Set Name, + -- | Mapping from GObject Introspection namespaces to pkg-config + pkgConfigMap :: M.Map Text Text, + -- | Version number for the generated .cabal package. + cabalPkgVersion :: Maybe Text, + -- | Prefered version of the namespace + nsChooseVersion :: M.Map String String +} + +-- | Construct the generic config for a module. +defaultOverrides :: Overrides +defaultOverrides = Overrides { + constantPrefix = M.empty, + ignoredElems = M.empty, + ignoredAPIs = S.empty, + sealedStructs = S.empty, + pkgConfigMap = M.empty, + cabalPkgVersion = Nothing, + nsChooseVersion = M.empty } + +-- | There is a sensible notion of zero and addition of Overridess, +-- encode this so that we can view the parser as a writer monad of +-- configs. +instance Monoid Overrides where + mempty = defaultOverrides + mappend a b = Overrides { + constantPrefix = constantPrefix a <> constantPrefix b, + ignoredAPIs = ignoredAPIs a <> ignoredAPIs b, + sealedStructs = sealedStructs a <> sealedStructs b, + ignoredElems = M.unionWith S.union (ignoredElems a) (ignoredElems b), + pkgConfigMap = pkgConfigMap a <> pkgConfigMap b, + cabalPkgVersion = if isJust (cabalPkgVersion b) + then cabalPkgVersion b + else cabalPkgVersion a, + nsChooseVersion = nsChooseVersion a <> nsChooseVersion b + } + +-- | We have a bit of context (the current namespace), and can fail, +-- encode this in a monad. +type Parser = WriterT Overrides (StateT (Maybe String) (Except Text)) () + +-- | Parse the given config file (as a set of lines) for a given +-- introspection namespace, filling in the configuration as needed. In +-- case the parsing fails we return a description of the error +-- instead. +parseOverridesFile :: [Text] -> Either Text Overrides +parseOverridesFile ls = runExcept $ flip evalStateT Nothing $ execWriterT $ + mapM (parseOneLine . T.strip) ls + +-- | Parse a single line of the config file, modifying the +-- configuration as appropriate. +parseOneLine :: Text -> Parser +-- Empty lines +parseOneLine line | T.null line = return () +-- Comments +parseOneLine (T.stripPrefix "#" -> Just _) = return () +parseOneLine (T.stripPrefix "namespace " -> Just ns) = + (put . Just . T.unpack . T.strip) ns +parseOneLine (T.stripPrefix "ignore " -> Just ign) = get >>= parseIgnore ign +parseOneLine (T.stripPrefix "constantPrefix " -> Just p) = get >>= parseConstP p +parseOneLine (T.stripPrefix "seal " -> Just s) = get >>= parseSeal s +parseOneLine (T.stripPrefix "pkg-config-name" -> Just s) = parsePkgConfigName s +parseOneLine (T.stripPrefix "cabal-pkg-version" -> Just s) = parseCabalPkgVersion s +parseOneLine (T.stripPrefix "namespace-version" -> Just s) = parseNsVersion s +parseOneLine l = throwError $ "Could not understand \"" <> l <> "\"." + +-- | Ignored elements. +parseIgnore :: Text -> Maybe String -> Parser +parseIgnore _ Nothing = + throwError "'ignore' requires a namespace to be defined first." +parseIgnore (T.words -> [T.splitOn "." -> [api,elem]]) (Just ns) = + tell $ defaultOverrides {ignoredElems = M.singleton (Name ns (T.unpack api)) + (S.singleton elem)} +parseIgnore (T.words -> [T.splitOn "." -> [api]]) (Just ns) = + tell $ defaultOverrides {ignoredAPIs = S.singleton (Name ns (T.unpack api))} +parseIgnore ignore _ = + throwError ("Ignore syntax is of the form \"ignore API.elem\" with '.elem' optional.\nGot \"ignore " <> ignore <> "\" instead.") + +-- | Prefix for constants. +parseConstP :: Text -> Maybe String -> Parser +parseConstP _ Nothing = throwError "'constantPrefix' requires a namespace to be defined first. " +parseConstP (T.words -> [p]) (Just ns) = tell $ + defaultOverrides {constantPrefix = M.singleton ns (T.unpack p)} +parseConstP prefix _ = + throwError ("constantPrefix syntax is of the form \"constantPrefix prefix\".\nGot \"constantPrefix " <> prefix <> "\" instead.") + +-- | Sealed structures. +parseSeal :: Text -> Maybe String -> Parser +parseSeal _ Nothing = throwError "'seal' requires a namespace to be defined first." +parseSeal (T.words -> [s]) (Just ns) = tell $ + defaultOverrides {sealedStructs = S.singleton (Name ns (T.unpack s))} +parseSeal seal _ = + throwError ("seal syntax is of the form \"seal name\".\nGot \"seal " + <> seal <> "\" instead.") + +-- | Mapping from GObject Introspection namespaces to pkg-config. +parsePkgConfigName :: Text -> Parser +parsePkgConfigName (T.words -> [gi,pc]) = tell $ + defaultOverrides {pkgConfigMap = + M.singleton (T.toLower gi) pc} +parsePkgConfigName t = + throwError ("pkg-config-name syntax is of the form\n" <> + "\t\"pkg-config-name gi-namespace pk-name\"\n" <> + "Got \"pkg-config-name " <> t <> "\" instead.") + +-- | Choose a preferred namespace version to load. +parseNsVersion :: Text -> Parser +parseNsVersion (T.words -> [ns,version]) = tell $ + defaultOverrides {nsChooseVersion = + M.singleton (T.unpack ns) (T.unpack version)} +parseNsVersion t = + throwError ("namespace-version syntax is of the form\n" <> + "\t\"namespace-version namespace version\"\n" <> + "Got \"namespace-version " <> t <> "\" instead.") + +-- | Specifying the cabal package version by hand. +parseCabalPkgVersion :: Text -> Parser +parseCabalPkgVersion (T.words -> [version]) = tell $ + defaultOverrides {cabalPkgVersion = Just version} +parseCabalPkgVersion t = + throwError ("cabal-pkg-version syntax is of the form\n" <> + "\t\"cabal-pkg-version version\"\n" <> + "Got \"cabal-pkg-version " <> t <> "\" instead.") + +-- | Filter a set of named objects based on a lookup list of names to +-- ignore. +filterNamed :: [(Name, a)] -> S.Set Text -> [(Name, a)] +filterNamed set ignores = + filter ((`S.notMember` ignores) . T.pack . name . fst) set + +-- | Filter one API according to the given config. +filterOneAPI :: Overrides -> (Name, API, Maybe (S.Set Text)) -> (Name, API) +filterOneAPI ovs (Name ns n, APIConst c, _) = + (Name ns (prefix ++ n), APIConst c) + where prefix = fromMaybe "_" $ M.lookup ns (constantPrefix ovs) +filterOneAPI ovs (n, APIStruct s, maybeIgnores) = + (n, APIStruct s {structMethods = maybe (structMethods s) + (filterNamed (structMethods s)) + maybeIgnores, + structFields = if n `S.member` sealedStructs ovs + then [] + else structFields s}) +-- The rest only apply if there are ignores. +filterOneAPI _ (n, api, Nothing) = (n, api) +filterOneAPI _ (n, APIObject o, Just ignores) = + (n, APIObject o {objMethods = filterNamed (objMethods o) ignores, + objSignals = filter ((`S.notMember` ignores) . sigName) + (objSignals o) + }) +filterOneAPI _ (n, APIInterface i, Just ignores) = + (n, APIInterface i {ifMethods = filterNamed (ifMethods i) ignores, + ifSignals = filter ((`S.notMember` ignores) . sigName) + (ifSignals i) + }) +filterOneAPI _ (n, APIUnion u, Just ignores) = + (n, APIUnion u {unionMethods = filterNamed (unionMethods u) ignores}) +filterOneAPI _ (n, api, _) = (n, api) + +-- | Given a list of APIs modify them according to the given config. +filterAPIs :: Overrides -> [(Name, API)] -> [(Name, API)] +filterAPIs ovs apis = map (filterOneAPI ovs . fetchIgnores) filtered + where filtered = filter ((`S.notMember` ignoredAPIs ovs) . fst) apis + fetchIgnores (n, api) = (n, api, M.lookup n (ignoredElems ovs)) + +-- | Load a given API, applying filtering. Load also any necessary +-- dependencies. +filterAPIsAndDeps :: Overrides -> GIRInfo -> [GIRInfo] + -> (M.Map Name API, M.Map Name API) +filterAPIsAndDeps ovs doc deps = + let toMap = M.fromList . filterAPIs ovs . girAPIs + in (toMap doc, M.unions (map toMap deps)) diff --git a/src/GI/PkgConfig.hs b/src/GI/PkgConfig.hs new file mode 100644 --- /dev/null +++ b/src/GI/PkgConfig.hs @@ -0,0 +1,47 @@ +module GI.PkgConfig + ( pkgConfigGetVersion + ) where + +import Control.Monad (when) +import Data.Monoid (First(..), (<>)) +#if !MIN_VERSION_base(4,8,0) +import Data.Monoid (mconcat) +#endif +import qualified Data.Map.Strict as M +import qualified Data.Text as T +import Data.Text (Text) +import System.Exit (ExitCode(..)) +import System.Process (readProcessWithExitCode) + +-- | Try asking pkg-config for the version of a given module. +tryPkgConfig :: Text -> IO (Maybe (Text, Text)) +tryPkgConfig pkgName = do + (exitcode, stdout, _) <- + readProcessWithExitCode "pkg-config" ["--modversion", T.unpack pkgName] "" + case exitcode of + ExitSuccess -> case lines stdout of + [v] -> return (Just (pkgName, T.pack v)) + _ -> return Nothing + ExitFailure _ -> return Nothing + +-- | Get the pkg-config name and associated installed version of a given +-- gobject-introspection namespace. Since the mapping is not +-- one-to-one some guessing is involved, although in most cases the +-- required information is listed in the GIR file. +pkgConfigGetVersion :: Text -- name + -> Text -- version + -> [Text] -- known package names + -> Bool -- verbose + -> M.Map Text Text -- suggested overrides + -> IO (Maybe (Text, Text)) +pkgConfigGetVersion name version packages verbose overridenNames = do + let lowerName = T.toLower name + when verbose $ + putStrLn $ T.unpack ("Querying pkg-config for " <> name <> + " version " <> version) + let alternatives = case M.lookup lowerName overridenNames of + Nothing -> packages ++ [lowerName <> "-" <> version, + lowerName] + Just n -> [n <> "-" <> version, n] + firstJust = getFirst . mconcat . map First + mapM tryPkgConfig alternatives >>= return . firstJust diff --git a/src/GI/ProjectInfo.hs b/src/GI/ProjectInfo.hs new file mode 100644 --- /dev/null +++ b/src/GI/ProjectInfo.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE TemplateHaskell #-} +-- | Project information to include in generated bindings, should be +-- kept in sync with haskell-gi.cabal +module GI.ProjectInfo + ( homepage + , authors + , license + , licenseText + , maintainers + ) where + +import Data.FileEmbed (embedStringFile) + +homepage :: String +homepage = "https://github.com/haskell-gi/haskell-gi" + +authors :: String +authors = "Will Thompson, Iñaki García Etxebarria and Jonas Platte" + +maintainers :: String +maintainers = "Iñaki García Etxebarria (garetxe@gmail.com)" + +license :: String +license = "LGPL-2.1" + +licenseText :: String +licenseText = $(embedStringFile "LICENSE") diff --git a/src/GI/Properties.hs b/src/GI/Properties.hs new file mode 100644 --- /dev/null +++ b/src/GI/Properties.hs @@ -0,0 +1,280 @@ +module GI.Properties + ( genInterfaceProperties + , genObjectProperties + ) where + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative ((<$>)) +#endif +import Control.Monad (forM_, when, unless) +import Data.List (intercalate) +import Data.Monoid ((<>)) +import qualified Data.Text as T + +import Foreign.Storable (sizeOf) +import Foreign.C (CInt, CUInt) + +import GI.API +import GI.Conversions +import GI.Code +import GI.GObject +import GI.Inheritance (fullObjectPropertyList, fullInterfacePropertyList) +import GI.SymbolNaming (upperNameWithSuffix, upperName, classConstraint, qualifyWithSuffix, hyphensToCamelCase) +import GI.Type +import GI.Util + +propTypeStr :: Type -> CodeGen String +propTypeStr t = case t of + TBasicType TUTF8 -> return "String" + TBasicType TFileName -> return "String" + TBasicType TVoid -> return "Ptr" + TByteArray -> return "ByteArray" + TGHash _ _ -> return "Hash" + TVariant -> return "Variant" + TParamSpec -> return "ParamSpec" + TBasicType TInt32 -> do + -- This should work for all systems in common use, but rather + -- than leaving the assumption implicit better double checking. + when (sizeOf (0 :: CInt) /= 4) $ + error "C Integers are not 4 bytes, unsupported platform." + return "CInt" + TBasicType TUInt32 -> do + when (sizeOf (0 :: CUInt) /= 4) $ + error "C Integers are not 4 bytes, unsupported platform." + return "CUInt" + TBasicType TInt64 -> return "Int64" + TBasicType TUInt64 -> return "UInt64" + TBasicType TBoolean -> return "Bool" + TBasicType TFloat -> return "Float" + TBasicType TDouble -> return "Double" + TBasicType TGType -> return "GType" + TCArray True _ _ (TBasicType TUTF8) -> return "StringArray" + TCArray True _ _ (TBasicType TFileName) -> return "StringArray" + TGList (TBasicType TVoid) -> return "PtrGList" + t@(TInterface ns n) -> do + api <- findAPIByName (Name ns n) + case api of + APIEnum _ -> return "Enum" + APIFlags _ -> return "Flags" + APIStruct s -> if structIsBoxed s + then return "Boxed" + else error $ "Unboxed struct property : " ++ show t + APIUnion u -> if unionIsBoxed u + then return "Boxed" + else error $ "Unboxed union property : " ++ show t + APIObject _ -> do + isGO <- isGObject t + if isGO + then return "Object" + else error $ "Non-GObject object property : " ++ show t + APIInterface _ -> do + isGO <- isGObject t + if isGO + then return "Object" + else error $ "Non-GObject interface property : " ++ show t + _ -> error $ "Unknown interface property of type : " ++ show t + _ -> error $ "Don't know how to handle properties of type " ++ show t + +-- Given a property, return the set of constraints on the types, and +-- the type variables for the object and its value. +attrType :: Property -> CodeGen ([String], String) +attrType prop = do + (_,t,constraints) <- argumentType ['a'..'l'] $ propType prop + if ' ' `elem` t + then return (constraints, parenthesize t) + else return (constraints, t) + +genPropertySetter :: Name -> String -> Property -> CodeGen () +genPropertySetter n pName prop = group $ do + oName <- upperName n + (constraints, t) <- attrType prop + let constraints' = "MonadIO m":(classConstraint oName ++ " o"):constraints + tStr <- propTypeStr $ propType prop + line $ "set" ++ pName ++ " :: (" ++ intercalate ", " constraints' + ++ ") => o -> " ++ t ++ " -> m ()" + line $ "set" ++ pName ++ " obj val = liftIO $ setObjectProperty" ++ tStr + ++ " obj \"" ++ T.unpack (propName prop) ++ "\" val" + +genPropertyGetter :: Name -> String -> Property -> CodeGen () +genPropertyGetter n pName prop = group $ do + oName <- upperName n + outType <- haskellType (propType prop) + let constraints = "(MonadIO m, " ++ classConstraint oName ++ " o)" + line $ "get" ++ pName ++ " :: " ++ constraints ++ + " => o -> " ++ show ("m" `con` [outType]) + tStr <- propTypeStr $ propType prop + line $ "get" ++ pName ++ " obj = liftIO $ getObjectProperty" ++ tStr + ++ " obj \"" ++ T.unpack (propName prop) ++ "\"" ++ + if tStr `elem` ["Object", "Boxed"] + then " " ++ show outType -- These require the constructor too. + else "" + +genPropertyConstructor :: String -> Property -> CodeGen () +genPropertyConstructor pName prop = group $ do + (constraints, t) <- attrType prop + tStr <- propTypeStr $ propType prop + let constraints' = + case constraints of + [] -> "" + _ -> parenthesize (intercalate ", " constraints) ++ " => " + line $ "construct" ++ pName ++ " :: " ++ constraints' + ++ t ++ " -> IO ([Char], GValue)" + line $ "construct" ++ pName ++ " val = constructObjectProperty" ++ tStr + ++ " \"" ++ T.unpack (propName prop) ++ "\" val" + +genObjectProperties :: Name -> Object -> CodeGen () +genObjectProperties n o = do + isGO <- apiIsGObject n (APIObject o) + -- We do not generate bindings for objects not descending from GObject. + when isGO $ do + allProps <- fullObjectPropertyList n o >>= + mapM (\(owner, prop) -> do + pi <- infoType owner prop + return $ "'(\"" ++ T.unpack (propName prop) + ++ "\", " ++ pi ++ ")") + genProperties n (objProperties o) allProps + +genInterfaceProperties :: Name -> Interface -> CodeGen () +genInterfaceProperties n iface = do + allProps <- fullInterfacePropertyList n iface >>= + mapM (\(owner, prop) -> do + pi <- infoType owner prop + return $ "'(\"" ++ T.unpack (propName prop) + ++ "\", " ++ pi ++ ")") + genProperties n (ifProperties iface) allProps + +-- If the given accesor is available (indicated by available == True), +-- generate a fully qualified accesor name, otherwise just return +-- "undefined". accessor is "get", "set" or "construct" +accessorOrUndefined :: Bool -> String -> Name -> String -> CodeGen String +accessorOrUndefined available accessor (Name ons on) cName = + if not available + then return "undefined" + else do + prefix <- qualifyWithSuffix "A." ons + return $ prefix ++ accessor ++ on ++ cName + +-- | The name of the type encoding the information for the property of +-- the object. +infoType :: Name -> Property -> CodeGen String +infoType owner prop = do + name <- upperNameWithSuffix "A." owner + let cName = (hyphensToCamelCase . T.unpack . propName) prop + return $ name ++ cName ++ "PropertyInfo" + +genOneProperty :: Name -> Property -> ExcCodeGen () +genOneProperty owner prop = do + name <- upperName owner + let cName = (hyphensToCamelCase . T.unpack . propName) prop + pName = name ++ cName + flags = propFlags prop + writable = PropertyWritable `elem` flags && + (PropertyConstructOnly `notElem` flags) + readable = PropertyReadable `elem` flags + constructOnly = PropertyConstructOnly `elem` flags + + -- For properties the meaning of having transfer /= TransferNothing + -- is not clear (what are the right semantics for GValue setters?), + -- and the other possibilities are very uncommon, so let us just + -- assume that TransferNothing is always the case. + when (propTransfer prop /= TransferNothing) $ + notImplementedError $ "Property " ++ pName + ++ " has unsupported transfer type " + ++ show (propTransfer prop) + + getter <- accessorOrUndefined readable "get" owner cName + setter <- accessorOrUndefined writable "set" owner cName + constructor <- accessorOrUndefined (writable || constructOnly) + "construct" owner cName + + unless (readable || writable || constructOnly) $ + notImplementedError $ "Property is not readable, writable, or constructible: " + ++ show pName + + group $ do + line $ "-- VVV Prop \"" ++ T.unpack (propName prop) ++ "\"" + line $ " -- Type: " ++ show (propType prop) + line $ " -- Flags: " ++ show (propFlags prop) + + when readable $ genPropertyGetter owner pName prop + when writable $ genPropertySetter owner pName prop + when (writable || constructOnly) $ genPropertyConstructor pName prop + + outType <- if not readable + then return "()" + else do + sOutType <- show <$> haskellType (propType prop) + return $ if ' ' `elem` sOutType + then parenthesize sOutType + else sOutType + + -- Polymorphic _label style lens + group $ do + inIsGO <- isGObject (propType prop) + hInType <- show <$> haskellType (propType prop) + let inConstraint = if writable || constructOnly + then if inIsGO + then classConstraint hInType + else "(~) " ++ if ' ' `elem` hInType + then parenthesize hInType + else hInType + else "(~) ()" + allowedOps = (if writable + then ["'AttrSet", "'AttrConstruct"] + else []) + <> (if constructOnly + then ["'AttrConstruct"] + else []) + <> (if readable + then ["'AttrGet"] + else []) + it <- infoType owner prop + + line $ "data " ++ it + line $ "instance AttrInfo " ++ it ++ " where" + indent $ do + line $ "type AttrAllowedOps " ++ it + ++ " = '[ " ++ intercalate ", " allowedOps ++ "]" + line $ "type AttrSetTypeConstraint " ++ it + ++ " = " ++ inConstraint + line $ "type AttrBaseTypeConstraint " ++ it + ++ " = " ++ classConstraint name + line $ "type AttrGetType " ++ it ++ " = " ++ outType + line $ "type AttrLabel " ++ it ++ " = \"" + ++ name ++ "::" ++ T.unpack (propName prop) ++ "\"" + line $ "attrGet _ = " ++ getter + line $ "attrSet _ = " ++ setter + line $ "attrConstruct _ = " ++ constructor + +-- | Generate a placeholder property for those cases in which code +-- generation failed. +genPlaceholderProperty :: Name -> Property -> CodeGen () +genPlaceholderProperty owner prop = do + line $ "-- XXX Placeholder" + it <- infoType owner prop + line $ "data " ++ it + line $ "instance AttrInfo " ++ it ++ " where" + indent $ do + line $ "type AttrAllowedOps " ++ it ++ " = '[]" + line $ "type AttrSetTypeConstraint " ++ it ++ " = (~) ()" + line $ "type AttrBaseTypeConstraint " ++ it ++ " = (~) ()" + line $ "type AttrGetType " ++ it ++ " = ()" + line $ "type AttrLabel " ++ it ++ " = \"\"" + line $ "attrGet = undefined" + line $ "attrSet = undefined" + line $ "attrConstruct = undefined" + +genProperties :: Name -> [Property] -> [String] -> CodeGen () +genProperties n ownedProps allProps = do + name <- upperName n + + forM_ ownedProps $ \prop -> do + handleCGExc (\err -> do + line $ "-- XXX Generation of property \"" + ++ T.unpack (propName prop) ++ "\" of object \"" + ++ name ++ "\" failed: " ++ describeCGError err + genPlaceholderProperty n prop) + (genOneProperty n prop) + + group $ line $ "type instance AttributeList " ++ name ++ " = '[ " + ++ intercalate ", " allProps ++ "]" diff --git a/src/GI/Signal.hs b/src/GI/Signal.hs new file mode 100644 --- /dev/null +++ b/src/GI/Signal.hs @@ -0,0 +1,312 @@ +module GI.Signal + ( genSignal + , genCallback + , signalHaskellName + ) where + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative ((<$>)) +#endif +import Control.Monad (forM, forM_, when, unless) + +import Data.List (intercalate) +import Data.Typeable (typeOf) +import Data.Bool (bool) +import qualified Data.Text as T + +import Text.Show.Pretty (ppShow) + +import GI.API +import GI.Callable (hOutType, arrayLengths, wrapMaybe) +import GI.Code +import GI.Conversions +import GI.SymbolNaming +import GI.Transfer (freeContainerType) +import GI.Type +import GI.Util (split, parenthesize, withComment) + +-- The prototype of the callback on the Haskell side (what users of +-- the binding will see) +genHaskellCallbackPrototype :: Callable -> String -> [Arg] -> [Arg] -> + ExcCodeGen () +genHaskellCallbackPrototype cb name' hInArgs hOutArgs = do + group $ do + line $ "type " ++ name' ++ " =" + indent $ do + forM_ hInArgs $ \arg -> do + ht <- haskellType (argType arg) + wrapMaybe arg >>= bool + (line $ show ht ++ " ->") + (line $ show (maybeT ht) ++ " ->") + ret <- hOutType cb hOutArgs False + line $ show $ io ret + + -- For optional parameters, in case we want to pass Nothing. + group $ do + line $ "no" ++ name' ++ " :: Maybe " ++ name' + line $ "no" ++ name' ++ " = Nothing" + +-- Prototype of the callback on the C side +genCCallbackPrototype :: Callable -> String -> Bool -> CodeGen () +genCCallbackPrototype cb name' isSignal = + group $ do + line $ "type " ++ name' ++ "C =" + indent $ do + when isSignal $ line $ withComment "Ptr () ->" "object" + forM_ (args cb) $ \arg -> do + ht <- foreignType $ argType arg + let ht' = if direction arg /= DirectionIn + then ptr ht + else ht + line $ show ht' ++ " ->" + when isSignal $ line $ withComment "Ptr () ->" "user_data" + ret <- io <$> case returnType cb of + TBasicType TVoid -> return $ typeOf () + t -> foreignType t + line $ show ret + +-- Generator for wrappers callable from C +genCallbackWrapperFactory :: String -> CodeGen () +genCallbackWrapperFactory name' = + group $ do + line "foreign import ccall \"wrapper\"" + indent $ line $ "mk" ++ name' ++ " :: " + ++ name' ++ "C -> IO (FunPtr " ++ name' ++ "C)" + +-- Generator of closures +genClosure :: String -> String -> Bool -> CodeGen () +genClosure callback closure isSignal = + group $ do + line $ closure ++ " :: " ++ callback ++ " -> IO Closure" + line $ closure ++ " cb = newCClosure =<< mk" ++ callback ++ " wrapped" + indent $ + line $ "where wrapped = " ++ lcFirst callback ++ "Wrapper " ++ + if isSignal + then "cb" + else "Nothing cb" + +-- Wrap a conversion of a nullable object into "Maybe" object, by +-- checking whether the pointer is NULL. +convertNullable :: String -> BaseCodeGen e String -> BaseCodeGen e String +convertNullable aname c = do + line $ "maybe" ++ ucFirst aname ++ " <-" + indent $ do + line $ "if " ++ aname ++ " == nullPtr" + line "then return Nothing" + line "else do" + indent $ do + unpacked <- c + line $ "return $ Just " ++ unpacked + return $ "maybe" ++ ucFirst aname + +-- Convert a non-zero terminated out array, stored in a variable +-- named "aname", into the corresponding Haskell object. +convertCallbackInCArray :: Callable -> Arg -> Type -> String -> ExcCodeGen String +convertCallbackInCArray callable arg t@(TCArray False (-1) length _) aname = + if length > -1 + then wrapMaybe arg >>= bool convertAndFree + (convertNullable aname convertAndFree) + else + -- Not much we can do, we just pass the pointer along, and let + -- the callback deal with it. + return aname + where + lname = escapeReserved $ argName $ args callable !! length + + convertAndFree :: ExcCodeGen String + convertAndFree = do + unpacked <- convert aname $ unpackCArray lname t (transfer arg) + -- Free the memory associated with the array + freeContainerType (transfer arg) t aname lname + return unpacked + +-- Remove the warning, this should never be reached. +convertCallbackInCArray _ t _ _ = + error $ "convertOutCArray : unexpected " ++ show t + +-- Prepare an argument for passing into the Haskell side. +prepareArgForCall :: Callable -> Arg -> ExcCodeGen String +prepareArgForCall cb arg = case direction arg of + DirectionIn -> prepareInArg cb arg + DirectionInout -> prepareInoutArg arg + DirectionOut -> error "Unexpected DirectionOut!" + +prepareInArg :: Callable -> Arg -> ExcCodeGen String +prepareInArg cb arg = do + let name = (escapeReserved . argName) arg + case argType arg of + t@(TCArray False _ _ _) -> convertCallbackInCArray cb arg t name + _ -> do + let c = convert name $ fToH (argType arg) (transfer arg) + wrapMaybe arg >>= bool c (convertNullable name c) + +prepareInoutArg :: Arg -> ExcCodeGen String +prepareInoutArg arg = do + let name = (escapeReserved . argName) arg + name' <- genConversion name $ apply $ M "peek" + convert name' $ fToH (argType arg) (transfer arg) + +saveOutArg :: Arg -> ExcCodeGen () +saveOutArg arg = do + let name = (escapeReserved . argName) arg + name' = "out" ++ name + when (transfer arg /= TransferEverything) $ + notImplementedError $ "Unexpected transfer type for \"" ++ name ++ "\"" + name'' <- convert name' $ hToF (argType arg) TransferEverything + line $ "poke " ++ name ++ " " ++ name'' + +-- The wrapper itself, marshalling to and from Haskell. The first +-- argument is possibly a pointer to a FunPtr to free (via +-- freeHaskellFunPtr) once the callback is run once, or Nothing if the +-- FunPtr will be freed by someone else (the function registering the +-- callback for ScopeTypeCall, or a destroy notifier for +-- ScopeTypeNotified). +genCallbackWrapper :: Callable -> String -> [Arg] -> [Arg] -> [Arg] -> + Bool -> ExcCodeGen () +genCallbackWrapper cb name' dataptrs hInArgs hOutArgs isSignal = do + let cName arg = if arg `elem` dataptrs + then "_" + else (escapeReserved . argName) arg + cArgNames = map cName (args cb) + + group $ do + line $ lcFirst name' ++ "Wrapper ::" + indent $ do + unless isSignal $ + line $ "Maybe (Ptr (FunPtr (" ++ name' ++ "C))) ->" + line $ name' ++ " ->" + when isSignal $ line "Ptr () ->" + forM_ (args cb) $ \arg -> do + ht <- foreignType $ argType arg + let ht' = if direction arg /= DirectionIn + then ptr ht + else ht + line $ show ht' ++ " ->" + when isSignal $ line "Ptr () ->" + ret <- io <$> case returnType cb of + TBasicType TVoid -> return $ typeOf () + t -> foreignType t + line $ show ret + + let allArgs = if isSignal + then unwords $ ["_cb", "_"] ++ cArgNames ++ ["_"] + else unwords $ ["funptrptr", "_cb"] ++ cArgNames + line $ lcFirst name' ++ "Wrapper " ++ allArgs ++ " = do" + indent $ do + hInNames <- forM hInArgs (prepareArgForCall cb) + + let maybeReturn = case returnType cb of + TBasicType TVoid -> [] + _ -> ["result"] + argName' = escapeReserved . argName + returnVars = maybeReturn ++ map (("out"++) . argName') hOutArgs + returnBind = case returnVars of + [] -> "" + [r] -> r ++ " <- " + _ -> parenthesize (intercalate ", " returnVars) ++ " <- " + line $ returnBind ++ "_cb " ++ concatMap (" " ++) hInNames + + forM_ hOutArgs saveOutArg + + unless isSignal $ line "maybeReleaseFunPtr funptrptr" + + when (returnType cb /= TBasicType TVoid) $ + if returnMayBeNull cb + then do + line "maybeM nullPtr result $ \\result' -> do" + indent $ unwrapped "result'" + else unwrapped "result" + where + unwrapped rname = do + result' <- convert rname $ hToF (returnType cb) (returnTransfer cb) + line $ "return " ++ result' + +genCallback :: Name -> Callback -> CodeGen () +genCallback n (Callback cb) = do + name' <- upperName n + line $ "-- callback " ++ name' + + let -- user_data pointers, which we generically omit + dataptrs = map (args cb !!) . filter (/= -1) . map argClosure $ args cb + hidden = dataptrs ++ arrayLengths cb + + inArgs = filter ((/= DirectionOut) . direction) $ args cb + hInArgs = filter (not . (`elem` hidden)) inArgs + outArgs = filter ((/= DirectionIn) . direction) $ args cb + hOutArgs = filter (not . (`elem` hidden)) outArgs + + if skipReturn cb + then group $ do + line $ "-- XXX Skipping callback " ++ name' + line $ "-- Callbacks skipping return unsupported :\n" + ++ ppShow n ++ "\n" ++ ppShow cb + else do + let closure = lcFirst name' ++ "Closure" + + handleCGExc (\e -> line ("-- XXX Could not generate callback wrapper for " + ++ name' ++ + "\n-- Error was : " ++ describeCGError e)) + (genClosure name' closure False >> + genCCallbackPrototype cb name' False >> + genCallbackWrapperFactory name' >> + genHaskellCallbackPrototype cb name' hInArgs hOutArgs >> + genCallbackWrapper cb name' dataptrs hInArgs hOutArgs False) + +-- | Return the name for the signal in Haskell CamelCase conventions. +signalHaskellName :: String -> String +signalHaskellName sn = let (w:ws) = split '-' sn + in w ++ concatMap ucFirst ws + +genSignal :: Signal -> Name -> ExcCodeGen () +genSignal (Signal { sigName = sn, sigCallable = cb }) on = do + on' <- upperName on + + line $ "-- signal " ++ on' ++ "::" ++ T.unpack sn + + let inArgs = filter ((/= DirectionOut) . direction) $ args cb + hInArgs = filter (not . (`elem` arrayLengths cb)) inArgs + outArgs = filter ((/= DirectionIn) . direction) $ args cb + hOutArgs = filter (not . (`elem` arrayLengths cb)) outArgs + sn' = signalHaskellName (T.unpack sn) + signalConnectorName = on' ++ ucFirst sn' + cbType = signalConnectorName ++ "Callback" + + genHaskellCallbackPrototype cb cbType hInArgs hOutArgs + + genCCallbackPrototype cb cbType True + + genCallbackWrapperFactory cbType + + let closure = lcFirst signalConnectorName ++ "Closure" + genClosure cbType closure True + + genCallbackWrapper cb cbType [] hInArgs hOutArgs True + + -- Wrapper for connecting functions to the signal + -- We can connect to a signal either before the default handler runs + -- ("on...") or after the default handler runs (after...). We + -- provide convenient wrappers for both cases. + group $ do + let signatureConstraints = "(GObject a, MonadIO m) =>" + signatureArgs = "a -> " ++ cbType ++ " -> m SignalHandlerId" + signature = " :: " ++ signatureConstraints ++ " " ++ signatureArgs + onName = "on" ++ signalConnectorName + afterName = "after" ++ signalConnectorName + line $ onName ++ signature + line $ onName ++ " obj cb = liftIO $ connect" + ++ signalConnectorName ++ " obj cb SignalConnectBefore" + line $ afterName ++ signature + line $ afterName ++ " obj cb = connect" + ++ signalConnectorName ++ " obj cb SignalConnectAfter" + + group $ do + let fullName = "connect" ++ signalConnectorName + signatureConstraints = "(GObject a, MonadIO m) =>" + signatureArgs = "a -> " ++ cbType + ++ " -> SignalConnectMode -> m SignalHandlerId" + line $ fullName ++ " :: " ++ signatureConstraints + line $ replicate (4 + length fullName) ' ' ++ signatureArgs + line $ fullName ++ " obj cb after = liftIO $ do" + indent $ do + line $ "cb' <- mk" ++ cbType ++ " (" ++ lcFirst cbType ++ "Wrapper cb)" + line $ "connectSignalFunPtr obj \"" ++ T.unpack sn ++ "\" cb' after" diff --git a/src/GI/Struct.hs b/src/GI/Struct.hs new file mode 100644 --- /dev/null +++ b/src/GI/Struct.hs @@ -0,0 +1,103 @@ +module GI.Struct ( genStructOrUnionFields + , extractCallbacksInStruct + , fixAPIStructs + , ignoreStruct) + where + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative ((<$>)) +#endif +import Control.Monad (forM_, unless, when) + +import Data.List (isSuffixOf) +import Data.Maybe (mapMaybe, isJust) +import Data.Text (unpack) + +import GI.API +import GI.Conversions +import GI.Code +import GI.SymbolNaming +import GI.Type +import GI.Util + +-- | Whether (not) to generate bindings for the given struct. +ignoreStruct :: Name -> Struct -> Bool +ignoreStruct (Name _ name) s = isJust (gtypeStructFor s) || + "Private" `isSuffixOf` name + +-- | Canonical name for the type of a callback type embedded in a +-- struct field. +fieldCallbackType :: String -> Field -> String +fieldCallbackType structName field = structName + ++ (underscoresToCamelCase . unpack . + fieldName) field + ++ "FieldCallback" + +-- | Fix the interface names of callback fields in the struct to +-- correspond to the ones that we are going to generate. +fixCallbackStructFields :: Name -> Struct -> Struct +fixCallbackStructFields (Name ns structName) s = s {structFields = fixedFields} + where fixedFields :: [Field] + fixedFields = map fixField (structFields s) + + fixField :: Field -> Field + fixField field = + case fieldCallback field of + Nothing -> field + Just _ -> let n' = fieldCallbackType structName field + in field {fieldType = TInterface ns n'} + +-- | Fix the interface names of callback fields in an APIStruct to +-- correspond to the ones that we are going to generate. If something +-- other than an APIStruct is passed in we don't touch it. +fixAPIStructs :: (Name, API) -> (Name, API) +fixAPIStructs (n, APIStruct s) = (n, APIStruct $ fixCallbackStructFields n s) +fixAPIStructs api = api + +-- | Extract the callback types embedded in the fields of structs, and +-- at the same time fix the type of the corresponding fields. Returns +-- the list of APIs associated to this struct, not including the +-- struct itself. +extractCallbacksInStruct :: (Name, API) -> [(Name, API)] +extractCallbacksInStruct (n@(Name ns structName), APIStruct s) + | ignoreStruct n s = [] + | otherwise = + mapMaybe callbackInField (structFields s) + where callbackInField :: Field -> Maybe (Name, API) + callbackInField field = do + callback <- fieldCallback field + let n' = fieldCallbackType structName field + return (Name ns n', APICallback callback) +extractCallbacksInStruct _ = [] + +buildFieldGetter :: Name -> Field -> ExcCodeGen () +buildFieldGetter n@(Name ns _) field = do + name' <- upperName n + + hType <- show <$> haskellType (fieldType field) + fType <- show <$> foreignType (fieldType field) + unless ("Private" `isSuffixOf` hType) $ do + fName <- upperName $ Name ns (unpack . fieldName $ field) + let getter = lcFirst name' ++ "Read" ++ fName + line $ getter ++ " :: " ++ name' ++ " -> IO " ++ + if ' ' `elem` hType + then parenthesize hType + else hType + line $ getter ++ " s = withManagedPtr s $ \\ptr -> do" + indent $ do + line $ "val <- peek (ptr `plusPtr` " ++ show (fieldOffset field) + ++ ") :: IO " ++ if ' ' `elem` fType + then parenthesize fType + else fType + result <- convert "val" $ fToH (fieldType field) TransferNothing + line $ "return " ++ result + +genStructOrUnionFields :: Name -> [Field] -> CodeGen () +genStructOrUnionFields n fields = do + name' <- upperName n + + forM_ fields $ \field -> when (fieldVisible field) $ group $ + handleCGExc (\e -> line ("-- XXX Skipped getter for \"" ++ name' ++ + ":" ++ unpack (fieldName field) ++ "\" :: " ++ + describeCGError e)) + (buildFieldGetter n field) diff --git a/src/GI/SymbolNaming.hs b/src/GI/SymbolNaming.hs new file mode 100644 --- /dev/null +++ b/src/GI/SymbolNaming.hs @@ -0,0 +1,129 @@ +module GI.SymbolNaming + ( qualify + , qualifyWithSuffix + , ucFirst + , lcFirst + , lowerName + , upperName + , upperNameWithSuffix + , noName + , escapeReserved + , classConstraint + , hyphensToCamelCase + , underscoresToCamelCase + ) where + +import Data.Char (toLower, toUpper) +#if !MIN_VERSION_base(4,8,0) +import Data.Monoid (Monoid, (<>)) +#else +import Data.Monoid ((<>)) +#endif +import Data.Text (Text) +import qualified Data.Text as T +import Data.String (IsString) + +import GI.API +import GI.Code +import GI.Config (Config(modName)) +import GI.Util (split) + +classConstraint :: (Monoid a, IsString a) => a -> a +classConstraint n = n <> "K" + +ucFirst (x:xs) = toUpper x : xs +ucFirst "" = error "ucFirst: empty string" + +lcFirst (x:xs) = toLower x : xs +lcFirst "" = error "lcFirst: empty string" + +lowerName :: Name -> CodeGen String +lowerName (Name _ s) = return $ concat . rename $ split '_' s + where + rename [w] = [lcFirst w] + rename (w:ws) = lcFirst w : map ucFirst' ws + rename [] = error "rename: empty list" + + ucFirst' "" = "_" + ucFirst' x = ucFirst x + +upperNameWithSuffix :: String -> Name -> CodeGen String +upperNameWithSuffix suffix (Name ns s) = do + prefix <- qualifyWithSuffix suffix ns + return $ prefix ++ uppered + where uppered = concatMap ucFirst' $ split '_' $ sanitize s + -- Move leading underscores to the end (for example in + -- GObject::_Value_Data_Union -> GObject::Value_Data_Union_) + sanitize ('_':xs) = sanitize xs ++ "_" + sanitize xs = xs + + ucFirst' "" = "_" + ucFirst' x = ucFirst x + +upperName :: Name -> CodeGen String +upperName = upperNameWithSuffix "." + +-- | Return a qualified prefix for the given namespace. In case the +-- namespace corresponds to the current module the empty string is +-- returned, otherwise the namespace ++ suffix is returned. Suffix is +-- typically just ".", see `qualify` below. +qualifyWithSuffix :: String -> String -> CodeGen String +qualifyWithSuffix suffix ns = do + cfg <- config + if modName cfg == Just ns then + return "" + else do + loadDependency ns -- Make sure that the given namespace is listed + -- as a dependency of this module. + return $ ucFirst ns ++ suffix + +-- | Return the qualified namespace (ns ++ "." or "", depending on +-- whether ns is the current namespace). +qualify :: String -> CodeGen String +qualify = qualifyWithSuffix "." + +-- | Save a bit of typing for optional arguments in the case that we +-- want to pass Nothing. +noName :: String -> CodeGen () +noName name' = group $ do + line $ "no" ++ name' ++ " :: Maybe " ++ name' + line $ "no" ++ name' ++ " = Nothing" + +-- | For a string of the form "one-sample-string" return "OneSampleString" +hyphensToCamelCase :: String -> String +hyphensToCamelCase str = concatMap ucFirst $ split '-' str + +-- | Similarly, turn a name separated_by_underscores into CamelCase. +underscoresToCamelCase :: String -> String +underscoresToCamelCase str = concatMap ucFirst $ split '_' str + +escapeReserved :: Text -> String +escapeReserved "type" = "type_" +escapeReserved "in" = "in_" +escapeReserved "data" = "data_" +escapeReserved "instance" = "instance_" +escapeReserved "where" = "where_" +escapeReserved "module" = "module_" +-- Reserved because we generate code that uses these names. +escapeReserved "result" = "result_" +escapeReserved "return" = "return_" +escapeReserved "show" = "show_" +escapeReserved "fromEnum" = "fromEnum_" +escapeReserved "toEnum" = "toEnum_" +escapeReserved "undefined" = "undefined_" +escapeReserved "error" = "error_" +escapeReserved "map" = "map_" +escapeReserved "length" = "length_" +escapeReserved "mapM" = "mapM__" +escapeReserved "mapM_" = "mapM___" +escapeReserved "fromIntegral" = "fromIntegral_" +escapeReserved "realToFrac" = "realToFrac_" +escapeReserved "peek" = "peek_" +escapeReserved "poke" = "poke_" +escapeReserved "sizeOf" = "sizeOf_" +escapeReserved "when" = "when_" +escapeReserved "default" = "default_" +escapeReserved s + | "set_" `T.isPrefixOf` s = T.unpack s <> "_" + | "get_" `T.isPrefixOf` s = T.unpack s <> "_" + | otherwise = T.unpack s diff --git a/src/GI/Transfer.hs b/src/GI/Transfer.hs new file mode 100644 --- /dev/null +++ b/src/GI/Transfer.hs @@ -0,0 +1,247 @@ +-- Routines dealing with memory management in marshalling functions. + +module GI.Transfer + ( freeInArg + , freeInArgOnError + , freeContainerType + ) where + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative ((<$>), (<*>)) +#endif + +import Control.Monad (when) +import Data.Maybe (isJust) + +import GI.API +import GI.Code +import GI.Conversions +import GI.GObject +import GI.SymbolNaming (ucFirst) +import GI.Type +import GI.Util + +-- Basic primitives for freeing the given types. Types that point to +-- Haskell objects with memory managed by the GC should not be freed +-- here. For containers this is only for freeing the container itself, +-- freeing the elements is done separately. +basicFreeFn :: Type -> Maybe String +basicFreeFn (TBasicType TUTF8) = Just "freeMem" +basicFreeFn (TBasicType TFileName) = Just "freeMem" +basicFreeFn (TBasicType _) = Nothing +basicFreeFn (TInterface _ _) = Nothing +basicFreeFn (TCArray False (-1) (-1) _) = Nothing -- Just passing it along +basicFreeFn (TCArray{}) = Just "freeMem" +basicFreeFn (TGArray _) = Just "unrefGArray" +basicFreeFn (TPtrArray _) = Just "unrefPtrArray" +basicFreeFn (TByteArray) = Just "unrefGByteArray" +basicFreeFn (TGList _) = Just "g_list_free" +basicFreeFn (TGSList _) = Just "g_slist_free" +basicFreeFn (TGHash _ _) = Just "unrefGHashTable" +basicFreeFn (TError) = Nothing +basicFreeFn (TVariant) = Nothing +basicFreeFn (TParamSpec) = Nothing + +-- Basic free primitives in the case that an error occured. This is +-- run in the exception handler, so any type which we ref/allocate +-- with the expectation that the called function will consume it (on +-- TransferEverything) should be freed here. +basicFreeFnOnError :: Type -> Transfer -> CodeGen (Maybe String) +basicFreeFnOnError (TBasicType TUTF8) _ = return $ Just "freeMem" +basicFreeFnOnError (TBasicType TFileName) _ = return $ Just "freeMem" +basicFreeFnOnError (TBasicType _) _ = return Nothing +basicFreeFnOnError TVariant transfer = + return $ if transfer == TransferEverything + then Just "unrefGVariant" + else Nothing +basicFreeFnOnError TParamSpec transfer = + return $ if transfer == TransferEverything + then Just "unrefGParamSpec" + else Nothing +basicFreeFnOnError t@(TInterface _ _) transfer = do + api <- findAPI t + case api of + Just (APIObject _) -> if transfer == TransferEverything + then do + isGO <- isGObject t + if isGO + then return $ Just "unrefObject" + else do + line "-- XXX Transfer a non-GObject object" + return Nothing + else return Nothing + Just (APIInterface _) -> if transfer == TransferEverything + then do + isGO <- isGObject t + if isGO + then return $ Just "unrefObject" + else do + line "-- XXX Transfer a non-GObject object" + return Nothing + else return Nothing + Just (APIUnion u) -> if transfer == TransferEverything + then if unionIsBoxed u + then return $ Just "freeBoxed" + else do + line "-- XXX Transfer a non-boxed union" + return Nothing + else return Nothing + Just (APIStruct s) -> if transfer == TransferEverything + then if structIsBoxed s + then return $ Just "freeBoxed" + else do + line "-- XXX Transfer a non-boxed struct" + return Nothing + else return Nothing + _ -> return Nothing +-- Arrays without length info are just passed along, we do not need to +-- free them. +basicFreeFnOnError (TCArray False (-1) (-1) _) _ = return Nothing +basicFreeFnOnError (TCArray{}) _ = return $ Just "freeMem" +basicFreeFnOnError (TGArray _) _ = return $ Just "unrefGArray" +basicFreeFnOnError (TPtrArray _) _ = return $ Just "unrefPtrArray" +basicFreeFnOnError (TByteArray) _ = return $ Just "unrefGByteArray" +basicFreeFnOnError (TGList _) _ = return $ Just "g_list_free" +basicFreeFnOnError (TGSList _) _ = return $ Just "g_slist_free" +basicFreeFnOnError (TGHash _ _) _ = return $ Just "unrefGHashTable" +basicFreeFnOnError (TError) _ = return Nothing + +-- Free just the container, but not the elements. +freeContainer :: Type -> String -> CodeGen [String] +freeContainer t label = + case basicFreeFn t of + Nothing -> return [] + Just fn -> return [fn ++ " " ++ label] + +-- Free one element using the given free function. +freeElem :: Type -> String -> String -> ExcCodeGen String +freeElem t label free = + case elementTypeAndMap t undefined of + Nothing -> return free + Just (TCArray False _ _ _, _) -> + badIntroError $ "Element type in container \"" ++ label ++ + "\" is an array of unknown length." + Just (innerType, mapFn) -> do + let elemFree = "freeElemOf" ++ ucFirst label + fullyFree innerType (prime label) >>= \case + Nothing -> return $ free ++ " e" + Just elemInnerFree -> do + line $ "let " ++ elemFree ++ " e = " ++ mapFn ++ " " + ++ elemInnerFree ++ " e >> " ++ free ++ " e" + return elemFree + +-- Construct a function to free the memory associated with a type, and +-- recursively free any elements of this type in case that it is a +-- container. +fullyFree :: Type -> String -> ExcCodeGen (Maybe String) +fullyFree t label = case basicFreeFn t of + Nothing -> return Nothing + Just free -> Just <$> freeElem t label free + +-- Like fullyFree, but free the toplevel element using basicFreeFnOnError. +fullyFreeOnError :: Type -> String -> Transfer -> ExcCodeGen (Maybe String) +fullyFreeOnError t label transfer = + basicFreeFnOnError t transfer >>= \case + Nothing -> return Nothing + Just free -> Just <$> freeElem t label free + +-- Free the elements in a container type. +freeElements :: Type -> String -> String -> ExcCodeGen [String] +freeElements t label len = + case elementTypeAndMap t len of + Nothing -> return [] + Just (inner, mapFn) -> + fullyFree inner label >>= \case + Nothing -> return [] + Just innerFree -> + return [mapFn ++ " " ++ innerFree ++ " " ++ label] + +-- | Free a container and/or the contained elements, depending on the +-- transfer mode. +freeContainerType :: Transfer -> Type -> String -> String -> ExcCodeGen () +freeContainerType transfer (TGHash _ _) label _ = freeGHashTable transfer label +freeContainerType transfer t label len = do + when (transfer == TransferEverything) $ + mapM_ line =<< freeElements t label len + when (transfer /= TransferNothing) $ + mapM_ line =<< freeContainer t label + +freeGHashTable :: Transfer -> String -> ExcCodeGen () +freeGHashTable TransferNothing _ = return () +freeGHashTable TransferContainer label = + notImplementedError $ "Hash table argument with transfer = Container? " + ++ label +-- Hash tables support setting a free function for keys and elements, +-- we assume that these are always properly set. The worst that can +-- happen this way is a memory leak, as opposed to a double free if we +-- try do free anything here. +freeGHashTable TransferEverything label = + line $ "unrefGHashTable " ++ label + +-- Free the elements of a container type in the case an error ocurred, +-- in particular args that should have been transferred did not get +-- transfered. +freeElementsOnError :: Transfer -> Type -> String -> String -> + ExcCodeGen [String] +freeElementsOnError transfer t label len = + case elementTypeAndMap t len of + Nothing -> return [] + Just (inner, mapFn) -> + fullyFreeOnError inner label transfer >>= \case + Nothing -> return [] + Just innerFree -> + return [mapFn ++ " " ++ innerFree ++ " " ++ label] + +freeIn :: Transfer -> Type -> String -> String -> ExcCodeGen [String] +freeIn transfer (TGHash _ _) label _ = + freeInGHashTable transfer label +freeIn transfer t label len = + case transfer of + TransferNothing -> (++) <$> freeElements t label len <*> freeContainer t label + TransferContainer -> freeElements t label len + TransferEverything -> return [] + +freeInOnError :: Transfer -> Type -> String -> String -> ExcCodeGen [String] +freeInOnError transfer (TGHash _ _) label _ = + freeInGHashTable transfer label +freeInOnError transfer t label len = + (++) <$> freeElementsOnError transfer t label len + <*> freeContainer t label + +-- See freeGHashTable above. +freeInGHashTable :: Transfer -> String -> ExcCodeGen [String] +freeInGHashTable TransferEverything _ = return [] +freeInGHashTable TransferContainer label = + notImplementedError $ "Hash table argument with TransferContainer? " + ++ label +freeInGHashTable TransferNothing label = return ["unrefGHashTable " ++ label] + +freeOut :: String -> CodeGen [String] +freeOut label = return ["freeMem " ++ label] + +-- | Given an input argument to a C callable, and its label in the code, +-- return the list of actions relevant to freeing the memory allocated +-- for the argument (if appropriate, depending on the ownership +-- transfer semantics of the callable). +freeInArg :: Arg -> String -> String -> ExcCodeGen [String] +freeInArg arg label len = do + weAlloc <- isJust <$> requiresAlloc (argType arg) + -- Arguments that we alloc ourselves do not need to be freed, they + -- will always be soaked up by the wrapPtr constructor, or they will + -- be DirectionIn. + if not weAlloc + then case direction arg of + DirectionIn -> freeIn (transfer arg) (argType arg) label len + DirectionOut -> freeOut label + DirectionInout -> freeOut label + else return [] + +-- | Same thing as freeInArg, but called in case the call to C didn't +-- succeed. We thus free everything we allocated in preparation for +-- the call, including args that would have been transferred to C. +freeInArgOnError :: Arg -> String -> String -> ExcCodeGen [String] +freeInArgOnError arg label len = + case direction arg of + DirectionIn -> freeInOnError (transfer arg) (argType arg) label len + DirectionOut -> freeOut label + DirectionInout -> freeOut label diff --git a/src/GI/Type.hs b/src/GI/Type.hs new file mode 100644 --- /dev/null +++ b/src/GI/Type.hs @@ -0,0 +1,67 @@ + +module GI.Type + ( BasicType(..) + , Type(..) + , io + , ptr + , con + , maybeT + ) where + +import Data.Typeable +import qualified Data.Text as T +import Data.Text (Text) + +-- This enum mirrors the definition in gitypes.h. +data BasicType + = TVoid + | TBoolean + | TInt8 + | TUInt8 + | TInt16 + | TUInt16 + | TInt32 + | TUInt32 + | TInt64 + | TUInt64 + | TFloat + | TDouble + | TUniChar + | TGType + | TUTF8 + | TFileName + deriving (Eq, Enum, Show, Ord) + +-- This type represents the types found in GObject Introspection +-- interfaces: the types of constants, arguments, etc. +data Type + = TBasicType BasicType + -- Zero terminated, Array Fixed Size, Array Length, Element Type + | TCArray Bool Int Int Type + | TGArray Type + | TPtrArray Type + | TByteArray + | TInterface String String + | TGList Type + | TGSList Type + | TGHash Type Type + | TError + | TVariant + | TParamSpec + deriving (Eq, Show, Ord) + +con :: Text -> [TypeRep] -> TypeRep +con "[]" xs = mkTyConApp listCon xs + where listCon = typeRepTyCon (typeOf [True]) +con "(,)" xs = mkTyConApp tupleCon xs + where tupleCon = typeRepTyCon (typeOf (True, True)) +con s xs = mkTyConApp (mkTyCon3 "GI" "GI" (T.unpack s)) xs + +io :: TypeRep -> TypeRep +io t = "IO" `con` [t] + +ptr :: TypeRep -> TypeRep +ptr t = "Ptr" `con` [t] + +maybeT :: TypeRep -> TypeRep +maybeT t = "Maybe" `con` [t] diff --git a/src/GI/Util.hs b/src/GI/Util.hs new file mode 100644 --- /dev/null +++ b/src/GI/Util.hs @@ -0,0 +1,60 @@ +module GI.Util + ( maybeWithCString + , getList + , toFlags + , split + + , prime + , unprime + , parenthesize + + , padTo + , withComment + ) where + +import Foreign +import Foreign.C + +import Data.List (unfoldr) + +padTo n s = s ++ replicate (n - length s) ' ' +withComment a b = padTo 40 a ++ "-- " ++ b + +maybeWithCString :: Maybe String -> (CString -> IO a) -> IO a +maybeWithCString = maybe ($ nullPtr) withCString + +getList :: (a -> IO CInt) -> (a -> CInt -> IO b) -> a -> IO [b] +getList getN getOne x = do + n <- getN x + mapM (getOne x) [0..n - 1] + +toFlags :: Enum a => CInt -> [a] +toFlags n = loop n (sizeOf n * 8 - 1) -- Number of bits in the argument + where loop _ (-1) = [] + loop n e = + let rest = loop n (e - 1) + in if testBit n e then toEnum (2 ^ e) : rest else rest + +-- Splits a string separated by the given separator into a list of +-- constituents. For example: split '.' "A.BC.D" = ["A", "BC", "D"] +split :: Char -> String -> [String] +split sep = unfoldr span' + where span' :: String -> Maybe (String, String) + span' [] = Nothing + span' s@(x:xs) + | x == sep = Just $ span (/= sep) xs + | otherwise = Just $ span (/= sep) s + +prime :: String -> String +prime = (++ "'") + +-- Remove the prime at the end of the given string +unprime :: String -> String +unprime "" = error "Empty variable to unprime!" +unprime primed = + case last primed of + '\'' -> init primed + _ -> error $ primed ++ " is not primed!" + +parenthesize :: String -> String +parenthesize s = "(" ++ s ++ ")" diff --git a/src/c/enumStorage.c b/src/c/enumStorage.c new file mode 100644 --- /dev/null +++ b/src/c/enumStorage.c @@ -0,0 +1,122 @@ +/* + Compute the number of bytes required for storage of a given enum, + assuming that the current compiler gives the same result as the + compiler used for compiling the library being introspected. + + Adapted from girepository/giroffsets.c, in the gobject-introspection + distribution. Original copyright below. +*/ + +/* -*- mode: C; c-file-style: "gnu"; indent-tabs-mode: nil; -*- + * GObject introspection: Compute structure offsets + * + * Copyright (C) 2008 Red Hat, Inc. + * + * This library is free software; you can redistribute it and/or + * modify it under the terms of the GNU Lesser General Public + * License as published by the Free Software Foundation; either + * version 2 of the License, or (at your option) any later version. + * + * This library is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public + * License along with this library; if not, write to the + * Free Software Foundation, Inc., 59 Temple Place - Suite 330, + * Boston, MA 02111-1307, USA. + */ + +/* The C standard specifies that an enumeration can be any char or any signed + * or unsigned integer type capable of representing all the values of the + * enumeration. We use test enumerations to figure out what choices the + * compiler makes. (Ignoring > 32 bit enumerations) + */ + +#include + +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); + } +} diff --git a/src/haskell-gi.hs b/src/haskell-gi.hs new file mode 100644 --- /dev/null +++ b/src/haskell-gi.hs @@ -0,0 +1,244 @@ +module Main where + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative ((<$>)) +import Data.Traversable (traverse) +#endif +import Control.Monad (forM_, when, (>=>)) +import Control.Exception (handle) + +import Data.Bool (bool) +import Data.List (intercalate) +import Data.Text (pack, unpack, Text) + +import System.Directory (createDirectoryIfMissing, doesFileExist) +import System.FilePath (splitPath, joinPath) +import System.Console.GetOpt +import System.Exit +import System.IO (hPutStr, hPutStrLn, stderr) +import System.Environment (getArgs) + +import qualified Data.Map as M +import qualified Data.Text as T +import qualified Data.Text.IO as TIO +import qualified Data.Set as S + +import Data.GI.Base.GError +import Text.Show.Pretty (ppShow) + +import GI.API (loadGIRInfo, loadRawGIRInfo, GIRInfo(girAPIs, girNSName), Name, API) +import GI.Cabal (cabalConfig, setupHs, genCabalProject) +import GI.Code (codeToString, genCode, evalCodeGen) +import GI.Config (Config(..)) +import GI.CodeGen (genModule) +import GI.Attributes (genAttributes, genAllAttributes) +import GI.OverloadedSignals (genSignalInstances, genOverloadedSignalConnectors) +import GI.Overrides (Overrides, parseOverridesFile, nsChooseVersion, filterAPIsAndDeps) +import GI.ProjectInfo (licenseText) +import GI.SymbolNaming (ucFirst) + +data Mode = GenerateCode | Dump | Attributes | Signals | Help + +data Options = Options { + optMode :: Mode, + optOutput :: Maybe String, + optOverridesFiles :: [String], + optSearchPaths :: [String], + optVerbose :: Bool, + optCabal :: Bool} + +defaultOptions = Options { + optMode = GenerateCode, + optOutput = Just "GI", + optOverridesFiles = [], + optSearchPaths = [], + optVerbose = False, + optCabal = True} + +parseKeyValue s = + let (a, '=':b) = break (=='=') s + in (a, b) + +optDescrs :: [OptDescr (Options -> Options)] +optDescrs = [ + Option "h" ["help"] (NoArg $ \opt -> opt { optMode = Help }) + "\tprint this gentle help text", + Option "a" ["attributes"] (NoArg $ \opt -> opt {optMode = Attributes}) + "generate generic attribute accesors", + Option "c" ["connectors"] (NoArg $ \opt -> opt {optMode = Signals}) + "generate generic signal connectors", + Option "d" ["dump"] (NoArg $ \opt -> opt { optMode = Dump }) + "\tdump internal representation", + Option "n" ["no-cabal"] (NoArg $ \opt -> opt {optCabal = False}) + "\tdo not generate .cabal file", + Option "o" ["overrides"] (ReqArg + (\arg opt -> opt {optOverridesFiles = + arg : optOverridesFiles opt}) + "OVERRIDES") + "specify a file with overrides info", + Option "O" ["output"] (ReqArg + (\arg opt -> opt {optOutput = Just arg}) "DIR") + "\tset the output directory", + Option "s" ["search"] (ReqArg + (\arg opt -> opt { optSearchPaths = arg : optSearchPaths opt }) "PATH") + "\tprepend a directory to the typelib search path", + Option "v" ["verbose"] (NoArg $ \opt -> opt { optVerbose = True }) + "\tprint extra info while processing"] + +showHelp = concatMap optAsLine optDescrs + where optAsLine (Option flag (long:_) _ desc) = + " -" ++ flag ++ "|--" ++ long ++ "\t" ++ desc ++ "\n" + optAsLine _ = error "showHelp" + +printGError = handle (gerrorMessage >=> putStrLn . unpack) + +outputPath :: Options -> IO (String, String) -- modPrefix, dirPrefix +outputPath options = + case optOutput options of + Nothing -> return ("", ".") + Just dir -> do + createDirectoryIfMissing True dir + let prefix = intercalate "." (splitPath dir) ++ "." + return (prefix, dir) + +-- | Load the given API and dependencies, filtering them in the process. +loadFilteredAPI :: Bool -> Overrides -> [FilePath] -> Text + -> IO (M.Map Name API, M.Map Name API) +loadFilteredAPI verbose ovs extraPaths name = do + (gir, girDeps) <- loadGIRInfo verbose name Nothing extraPaths + return $ filterAPIsAndDeps ovs gir girDeps + +-- | Load a dependency without further postprocessing. +loadRawAPIs :: Bool -> [FilePath] -> Text -> IO [(Name, API)] +loadRawAPIs verbose extraPaths name = do + gir <- loadRawGIRInfo verbose name Nothing extraPaths + return (girAPIs gir) + +-- Generate all generic accessor functions ("_label", for example). +genGenericAttrs :: Options -> Overrides -> [Text] -> [FilePath] -> IO () +genGenericAttrs options ovs modules extraPaths = do + apis <- mapM (loadRawAPIs (optVerbose options) extraPaths) modules + let allAPIs = M.unions (map M.fromList apis) + cfg = Config {modName = Nothing, + verbose = optVerbose options, + overrides = ovs} + (modPrefix, dirPrefix) <- outputPath options + putStrLn $ "\t* Generating " ++ modPrefix ++ "Properties" + (_, code) <- genCode cfg allAPIs (genAllAttributes (M.toList allAPIs) modPrefix) + writeFile (joinPath [dirPrefix, "Properties.hs"]) $ codeToString code + +-- Generate generic signal connectors ("Clicked", "Activate", ...) +genGenericConnectors :: Options -> Overrides -> [Text] -> [FilePath] -> IO () +genGenericConnectors options ovs modules extraPaths = do + apis <- mapM (loadRawAPIs (optVerbose options) extraPaths) modules + let allAPIs = M.unions (map M.fromList apis) + cfg = Config {modName = Nothing, + verbose = optVerbose options, + overrides = ovs} + (modPrefix, dirPrefix) <- outputPath options + putStrLn $ "\t* Generating " ++ modPrefix ++ "Signals" + (_, code) <- genCode cfg allAPIs (genOverloadedSignalConnectors (M.toList allAPIs) modPrefix) + writeFile (joinPath [dirPrefix, "Signals.hs"]) $ codeToString code + +-- Generate the code for the given module, and return the dependencies +-- for this module. +processMod :: Options -> Overrides -> [FilePath] -> String -> IO () +processMod options ovs extraPaths name = do + (gir, girDeps) <- loadGIRInfo (optVerbose options) (T.pack name) Nothing extraPaths + let (apis, deps) = filterAPIsAndDeps ovs gir girDeps + allAPIs = M.union apis deps + + let cfg = Config {modName = Just name, + verbose = optVerbose options, + overrides = ovs} + nm = ucFirst name + + (modPrefix, dirPrefix) <- outputPath options + + putStrLn $ "\t* Generating " ++ modPrefix ++ nm + (modDeps, code) <- genCode cfg allAPIs (genModule name (M.toList apis) modPrefix) + writeFile (joinPath [dirPrefix, nm ++ ".hs"]) $ + codeToString code + + putStrLn $ "\t\t+ " ++ modPrefix ++ nm ++ "Attributes" + (attrDeps, attrCode) <- genCode cfg allAPIs (genAttributes name (M.toList apis) modPrefix) + writeFile (joinPath [dirPrefix, nm ++ "Attributes.hs"]) $ + codeToString attrCode + + putStrLn $ "\t\t+ " ++ modPrefix ++ nm ++ "Signals" + (sigDeps, signalCode) <- genCode cfg allAPIs (genSignalInstances name (M.toList apis) modPrefix) + writeFile (joinPath [dirPrefix, nm ++ "Signals.hs"]) $ + codeToString signalCode + + when (optCabal options) $ do + let cabal = nm ++ ".cabal" + fname <- doesFileExist cabal >>= + bool (return cabal) + (putStrLn (cabal ++ " exists, writing " + ++ cabal ++ ".new instead") >> + return (cabal ++ ".new")) + putStrLn $ "\t\t+ " ++ fname + let usedDeps = S.delete name -- The module is not a dep of itself + $ S.unions [modDeps, attrDeps, sigDeps] + -- We only list as dependencies in the cabal file the + -- dependencies that we use, disregarding what the .gir file says. + actualDeps = filter ((`S.member` usedDeps) . T.unpack . girNSName) girDeps + (err, cabalCode) <- evalCodeGen cfg allAPIs (genCabalProject gir actualDeps modPrefix) + case err of + Nothing -> do + writeFile fname (codeToString cabalCode) + putStrLn "\t\t+ cabal.config" + writeFile "cabal.config" (T.unpack cabalConfig) + putStrLn "\t\t+ Setup.hs" + writeFile "Setup.hs" (T.unpack setupHs) + putStrLn "\t\t+ LICENSE" + writeFile "LICENSE" (licenseText) + Just msg -> putStrLn $ "ERROR: could not generate " ++ fname + ++ "\nError was: " ++ msg + +dump :: Options -> Overrides -> String -> IO () +dump options ovs name = do + (doc, _) <- loadGIRInfo (optVerbose options) (pack name) (pack <$> M.lookup name (nsChooseVersion ovs)) (optSearchPaths options) + mapM_ (putStrLn . ppShow) (girAPIs doc) + +process :: Options -> [String] -> IO () +process options names = do + let extraPaths = optSearchPaths options + configs <- traverse TIO.readFile (optOverridesFiles options) + case parseOverridesFile (concatMap T.lines configs) of + Left errorMsg -> do + hPutStr stderr "Error when parsing the config file(s):\n" + hPutStr stderr (T.unpack errorMsg) + exitFailure + Right ovs -> + case optMode options of + GenerateCode -> forM_ names (processMod options ovs extraPaths) + Attributes -> genGenericAttrs options ovs (map T.pack names) extraPaths + Signals -> genGenericConnectors options ovs (map T.pack names) extraPaths + Dump -> forM_ names (dump options ovs) + Help -> putStr showHelp + +foreign import ccall "g_type.h g_type_init" + g_type_init :: IO () + +main :: IO () +main = printGError $ do + g_type_init -- Initialize GLib's type system. + args <- getArgs + let (actions, nonOptions, errors) = getOpt RequireOrder optDescrs args + options = foldl (.) id actions defaultOptions + + case errors of + [] -> return () + _ -> do + mapM_ (hPutStr stderr) errors + exitFailure + + case nonOptions of + [] -> failWithUsage + names -> process options names + where + failWithUsage = do + hPutStrLn stderr "usage: haskell-gi [options] module1 [module2 [...]]" + hPutStr stderr showHelp + exitFailure