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-base.cabal b/haskell-gi-base.cabal new file mode 100644 --- /dev/null +++ b/haskell-gi-base.cabal @@ -0,0 +1,50 @@ +name: haskell-gi-base +version: 0.8 +synopsis: Foundation for libraries generated by haskell-gi +description: Foundation for libraries generated by haskell-gi +homepage: https://github.com/haskell-gi/haskell-gi-base +license: LGPL-2.1 + -- or above +license-file: LICENSE +author: Will Thompson, + Iñaki García Etxebarria, + Jonas Platte +maintainer: Iñaki García Etxebarria (garetxe@gmail.com) +stability: Experimental +category: Development +build-type: Simple +cabal-version: >=1.8 + +source-repository head + type: git + location: git://github.com/haskell-gi/haskell-gi-base.git + +library + hs-source-dirs: src + exposed-modules: Data.GI.Base, + Data.GI.Base.Attributes, + Data.GI.Base.BasicConversions, + Data.GI.Base.BasicTypes, + Data.GI.Base.Closure, + Data.GI.Base.GError, + Data.GI.Base.GHashTable, + Data.GI.Base.GValue, + Data.GI.Base.GVariant, + Data.GI.Base.ManagedPtr, + Data.GI.Base.GParamSpec, + Data.GI.Base.Overloading, + Data.GI.Base.Properties, + Data.GI.Base.ShortPrelude, + Data.GI.Base.Signals, + Data.GI.Base.Utils + + pkgconfig-depends: gobject-2.0 >= 2.36 + build-depends: base >= 4 && < 5, + bytestring, + containers, + text >= 1.0 + + build-tools: hsc2hs + extensions: CPP, ForeignFunctionInterface, DoAndIfThenElse + ghc-options: -Wall -fno-warn-missing-signatures -fwarn-incomplete-patterns -fno-warn-name-shadowing + c-sources: src/c/hsgclosure.c diff --git a/src/Data/GI/Base.hs b/src/Data/GI/Base.hs new file mode 100644 --- /dev/null +++ b/src/Data/GI/Base.hs @@ -0,0 +1,35 @@ +{- | + == Convenience header for basic GObject-Introspection modules + +See the documentation for each individual module for a description and +usage help. +-} +module Data.GI.Base + ( module Data.GI.Base.Attributes + , module Data.GI.Base.BasicConversions + , module Data.GI.Base.BasicTypes + , module Data.GI.Base.Closure + , module Data.GI.Base.GError + , module Data.GI.Base.GHashTable + , module Data.GI.Base.GValue + , module Data.GI.Base.GVariant + , module Data.GI.Base.GParamSpec + , module Data.GI.Base.ManagedPtr + , module Data.GI.Base.Properties + , module Data.GI.Base.Signals + , module Data.GI.Base.Utils + ) where + +import Data.GI.Base.Attributes +import Data.GI.Base.BasicConversions +import Data.GI.Base.BasicTypes +import Data.GI.Base.Closure +import Data.GI.Base.GError +import Data.GI.Base.GHashTable +import Data.GI.Base.GValue +import Data.GI.Base.GVariant +import Data.GI.Base.GParamSpec +import Data.GI.Base.ManagedPtr +import Data.GI.Base.Properties +import Data.GI.Base.Signals +import Data.GI.Base.Utils diff --git a/src/Data/GI/Base/Attributes.hs b/src/Data/GI/Base/Attributes.hs new file mode 100644 --- /dev/null +++ b/src/Data/GI/Base/Attributes.hs @@ -0,0 +1,241 @@ +{-# LANGUAGE GADTs, ScopedTypeVariables, DataKinds, KindSignatures, + TypeFamilies, TypeOperators, MultiParamTypeClasses, ConstraintKinds, + UndecidableInstances #-} + +-- | +-- +-- == Basic attributes interface +-- +-- Attributes of an object can be get, set and constructed. For types +-- descending from 'Data.GI.Base.BasicTypes.GObject', properties are +-- encoded in attributes, although attributes are slightly more +-- general (every property of a `Data.GI.Base.BasicTypes.GObject` is an +-- attribute, but we can also have attributes for types not descending +-- from `Data.GI.Base.BasicTypes.GObject`). +-- +-- As an example consider a @button@ widget and a property (of the +-- Button class, or any of its parent classes or implemented +-- interfaces) called "label". The simplest way of getting the value +-- of the button is to do +-- +-- > value <- getButtonLabel button +-- +-- And for setting: +-- +-- > setButtonLabel button label +-- +-- This mechanism quickly becomes rather cumbersome, for example for +-- setting the "window" property in a DOMDOMWindow in WebKit: +-- +-- > win <- getDOMDOMWindowWindow dom +-- +-- and perhaps more importantly, one needs to chase down the type +-- which introduces the property: +-- +-- > setWidgetSensitive button False +-- +-- There is no @setButtonSensitive@, since it is the @Widget@ type +-- that introduces the "sensitive" property. +-- +-- == Overloaded attributes +-- +-- A much more convenient overloaded attribute resolution API is +-- provided by this module. Getting the value of an object's attribute +-- is straightforward: +-- +-- > value <- get button _label +-- +-- The definition of @_label@ is simply a 'Proxy' encoding the name of +-- the attribute to get: +-- +-- > _label = Proxy :: Proxy "label" +-- +-- These proxies can be automatically generated by invoking the code +-- generator with the @-a@ option. The leading underscore is simply so +-- the autogenerated identifiers do not pollute the namespace, but if +-- this is not a concern the autogenerated names (in the autogenerated +-- @GI/Properties.hs@) can be edited as one wishes. +-- +-- The syntax for setting or updating an attribute is only slightly more +-- complex. At the simplest level it is just: +-- +-- > set button [ _label := value ] +-- +-- or for the WebKit example above +-- +-- > set dom [_window := win] +-- +-- However as the list notation would indicate, you can set or update multiple +-- attributes of the same object in one go: +-- +-- > set button [ _label := value, _sensitive := False ] +-- +-- You are not limited to setting the value of an attribute, you can also +-- apply an update function to an attribute's value. That is the function +-- receives the current value of the attribute and returns the new value. +-- +-- > set spinButton [ _value :~ (+1) ] +-- +-- There are other variants of these operators, (see 'AttrOp'). ':=>' and +-- ':~>' and like ':=' and ':~' but operate in the 'IO' monad rather +-- than being pure. There is also '::=' and '::~' which take the object +-- as an extra parameter. +-- +-- Attributes can also be set during construction of a +-- `Data.GI.Base.BasicTypes.GObject` using `Data.GI.Base.Properties.new` +-- +-- > button <- new Button [_label := "Can't touch this!", _sensitive := False] +-- +-- In addition for value being set/get having to have the right type, +-- there can be attributes that are read-only, or that can only be set +-- during construction with `Data.GI.Base.Properties.new`, but cannot be +-- `set` afterwards. That these invariants hold is also checked during +-- compile time. +-- +module Data.GI.Base.Attributes ( + AttrInfo(..), + + AttrOpTag(..), + + AttrOp(..), + get, + set + ) where + +import Data.Proxy (Proxy(..)) + +import Data.GI.Base.GValue (GValue(..)) +import Data.GI.Base.Overloading (ResolveAttribute) + +import GHC.TypeLits +import GHC.Exts (Constraint) + +infixr 0 :=,:~,:=>,:~>,::=,::~ + +-- | Info describing an attribute. +class AttrInfo (info :: *) where + -- | The operations that are allowed on the attribute. + type AttrAllowedOps info :: [AttrOpTag] + -- | Constraint on the value being set. + type AttrSetTypeConstraint info :: * -> Constraint + -- | Constraint on the type for which we are allowed to + -- create\/set\/get the attribute. + type AttrBaseTypeConstraint info :: * -> Constraint + -- | Type returned by `attrGet`. + type AttrGetType info + -- | A string describing the attribute (for error messages). + type AttrLabel info :: Symbol + -- | Get the value of the given attribute. + attrGet :: AttrBaseTypeConstraint info o => + proxy info -> o -> IO (AttrGetType info) + -- | Set the value of the given attribute, after the object having + -- the attribute has already been created. + attrSet :: (AttrBaseTypeConstraint info o, + AttrSetTypeConstraint info b) => + proxy info -> o -> b -> IO () + -- | Build a `GValue` representing the attribute. + attrConstruct :: AttrSetTypeConstraint info b => + proxy info -> b -> IO (String, GValue) + +-- | Result of checking whether an op is allowed on an attribute. +data OpAllowed tag attrName = + OpIsAllowed | AttrOpNotAllowed Symbol tag Symbol attrName + +-- | Look in the given list to see if the given `AttrOp` is a member, +-- if not return an error type. +type family AttrOpIsAllowed (tag :: AttrOpTag) (ops :: [AttrOpTag]) (label :: Symbol) :: OpAllowed AttrOpTag Symbol where + AttrOpIsAllowed tag '[] label = + 'AttrOpNotAllowed "Error: operation " tag " not allowed for attribute type " label + AttrOpIsAllowed tag (tag ': ops) label = 'OpIsAllowed + AttrOpIsAllowed tag (other ': ops) label = AttrOpIsAllowed tag ops label + +-- | Whether a given `AttrOpTag` is allowed on an attribute, given the +-- info type. +type family AttrOpAllowed (tag :: AttrOpTag) (info :: *) :: Constraint where + AttrOpAllowed tag info = + AttrOpIsAllowed tag (AttrAllowedOps info) (AttrLabel info) ~ 'OpIsAllowed + +-- | Possible operations on an attribute. +data AttrOpTag = AttrGet | AttrSet | AttrConstruct + +-- | Constructors for the different operations allowed on an attribute. +data AttrOp obj (tag :: AttrOpTag) where + -- Assign a value to an attribute + (:=) :: (info ~ ResolveAttribute attr obj, + AttrInfo info, + AttrBaseTypeConstraint info obj, + AttrOpAllowed tag info, + (AttrSetTypeConstraint info) b) => + proxy (attr :: Symbol) -> b -> AttrOp obj tag + -- Assign the result of an IO action to an attribute + (:=>) :: (info ~ ResolveAttribute attr obj, + AttrInfo info, + AttrBaseTypeConstraint info obj, + AttrOpAllowed tag info, + (AttrSetTypeConstraint info) b) => + proxy (attr :: Symbol) -> IO b -> AttrOp obj tag + -- Apply an update function to an attribute + (:~) :: (info ~ ResolveAttribute attr obj, + AttrInfo info, + AttrBaseTypeConstraint info obj, + tag ~ 'AttrSet, + AttrOpAllowed 'AttrSet info, + AttrOpAllowed 'AttrGet info, + (AttrSetTypeConstraint info) b, + a ~ (AttrGetType info)) => + proxy (attr :: Symbol) -> (a -> b) -> AttrOp obj tag + -- Apply an IO update function to an attribute + (:~>) :: (info ~ ResolveAttribute attr obj, + AttrInfo info, + AttrBaseTypeConstraint info obj, + tag ~ 'AttrSet, + AttrOpAllowed 'AttrSet info, + AttrOpAllowed 'AttrGet info, + (AttrSetTypeConstraint info) b, + a ~ (AttrGetType info)) => + proxy (attr :: Symbol) -> (a -> IO b) -> AttrOp obj tag + -- Assign a value to an attribute with the object as an argument + (::=) :: (info ~ ResolveAttribute attr obj, + AttrInfo info, + AttrBaseTypeConstraint info obj, + tag ~ 'AttrSet, + AttrOpAllowed tag info, + (AttrSetTypeConstraint info) b) => + proxy (attr :: Symbol) -> (obj -> b) -> AttrOp obj tag + -- Apply an update function to an attribute with the object as an + -- argument + (::~) :: (info ~ ResolveAttribute attr obj, + AttrInfo info, + AttrBaseTypeConstraint info obj, + tag ~ 'AttrSet, + AttrOpAllowed 'AttrSet info, + AttrOpAllowed 'AttrGet info, + (AttrSetTypeConstraint info) b, + a ~ (AttrGetType info)) => + proxy (attr :: Symbol) -> (obj -> a -> b) -> AttrOp obj tag + +-- | Set a number of properties for some object. +set :: forall o. o -> [AttrOp o 'AttrSet] -> IO () +set obj = mapM_ app + where + resolve :: proxy attr -> Proxy (ResolveAttribute attr o) + resolve _ = Proxy + + app :: AttrOp o 'AttrSet -> IO () + app (attr := x) = attrSet (resolve attr) obj x + app (attr :=> x) = x >>= attrSet (resolve attr) obj + app (attr :~ f) = attrGet (resolve attr) obj >>= + \v -> attrSet (resolve attr) obj (f v) + app (attr :~> f) = attrGet (resolve attr) obj >>= f >>= + attrSet (resolve attr) obj + app (attr ::= f) = attrSet (resolve attr) obj (f obj) + app (attr ::~ f) = attrGet (resolve attr) obj >>= + \v -> attrSet (resolve attr) obj (f obj v) + +-- | Get the value of an attribute for an object. +get :: forall info attr obj proxy. + (info ~ ResolveAttribute attr obj, AttrInfo info, + (AttrBaseTypeConstraint info) obj, + AttrOpAllowed 'AttrGet info) => + obj -> proxy (attr :: Symbol) -> IO (AttrGetType info) +get o _ = attrGet (Proxy :: Proxy info) o diff --git a/src/Data/GI/Base/BasicConversions.hsc b/src/Data/GI/Base/BasicConversions.hsc new file mode 100644 --- /dev/null +++ b/src/Data/GI/Base/BasicConversions.hsc @@ -0,0 +1,595 @@ +{-# LANGUAGE ScopedTypeVariables #-} +module Data.GI.Base.BasicConversions + ( gflagsToWord + , wordToGFlags + + , packGList + , unpackGList + , packGSList + , unpackGSList + , packGArray + , unpackGArray + , unrefGArray + , packGPtrArray + , unpackGPtrArray + , unrefPtrArray + , packGByteArray + , unpackGByteArray + , unrefGByteArray + , packGHashTable + , unpackGHashTable + , unrefGHashTable + , packByteString + , packZeroTerminatedByteString + , unpackByteStringWithLength + , unpackZeroTerminatedByteString + , packFileNameArray + , packZeroTerminatedFileNameArray + , unpackZeroTerminatedFileNameArray + , unpackFileNameArrayWithLength + , packUTF8CArray + , packZeroTerminatedUTF8CArray + , unpackUTF8CArrayWithLength + , unpackZeroTerminatedUTF8CArray + , packStorableArray + , packZeroTerminatedStorableArray + , unpackStorableArrayWithLength + , unpackZeroTerminatedStorableArray + , packMapStorableArray + , packMapZeroTerminatedStorableArray + , unpackMapStorableArrayWithLength + , unpackMapZeroTerminatedStorableArray + , packPtrArray + , packZeroTerminatedPtrArray + , unpackPtrArrayWithLength + , unpackZeroTerminatedPtrArray + , packBlockArray + , unpackBlockArrayWithLength + , unpackBoxedArrayWithLength + + , stringToCString + , cstringToString + , textToCString + , withTextCString + , cstringToText + , byteStringToCString + , cstringToByteString + + , mapZeroTerminatedCArray + , mapCArrayWithLength + , mapGArray + , mapPtrArray + , mapGList + , mapGSList + ) where + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative ((<$>), (<*>)) +#endif +import Control.Exception.Base (bracket) +import Control.Monad (foldM) + +import Data.ByteString (ByteString) +import qualified Data.ByteString as B +import qualified Data.ByteString.Internal as BI +import Data.Maybe (fromMaybe) +import Data.Text (Text) +import qualified Data.Text.Foreign as TF + +import Foreign.Ptr (Ptr, plusPtr, nullPtr, nullFunPtr, castPtr) +import Foreign.ForeignPtr (withForeignPtr) +import Foreign.Storable (Storable, peek, poke, sizeOf) +import Foreign.C.Types (CInt(..), CUInt(..), CSize(..), CChar(..)) +import Foreign.C.String (CString, withCString, peekCString) +import Data.Word (Word8, Word64) +import Data.Int (Int32) +import Data.Bits (Bits, (.|.), (.&.), shift) + +import Data.GI.Base.BasicTypes +import Data.GI.Base.GHashTable (GEqualFunc, GHashFunc) +import Data.GI.Base.ManagedPtr (copyBoxedPtr) +import Data.GI.Base.Utils (allocBytes, callocBytes, memcpy, freeMem) + +#include + +gflagsToWord :: (Num b, IsGFlag a) => [a] -> b +gflagsToWord flags = fromIntegral (go flags) + where go (f:fs) = fromEnum f .|. go fs + go [] = 0 + +wordToGFlags :: forall a b. (Storable a, Integral a, Bits a, IsGFlag b) => + a -> [b] +wordToGFlags w = go 0 + where + nbits = (sizeOf (undefined :: a))*8 + go k + | k == nbits = [] + | otherwise = if mask .&. w /= 0 + then toEnum (fromIntegral mask) : go (k+1) + else go (k+1) + where mask = shift 1 k + +foreign import ccall "g_list_prepend" g_list_prepend :: + Ptr (GList (Ptr a)) -> Ptr a -> IO (Ptr (GList (Ptr a))) + +-- Given a Haskell list of items, construct a GList with those values. +packGList :: [Ptr a] -> IO (Ptr (GList (Ptr a))) +packGList l = foldM g_list_prepend nullPtr $ reverse l + +-- Given a GSList construct the corresponding Haskell list. +unpackGList :: Ptr (GList (Ptr a)) -> IO [Ptr a] +unpackGList gsl + | gsl == nullPtr = return [] + | otherwise = + do x <- peek (castPtr gsl) + next <- peek (gsl `plusPtr` sizeOf x) + xs <- unpackGList next + return $ x : xs + +-- Same thing for singly linked lists + +foreign import ccall "g_slist_prepend" g_slist_prepend :: + Ptr (GSList (Ptr a)) -> Ptr a -> IO (Ptr (GSList (Ptr a))) + +-- Given a Haskell list of items, construct a GSList with those values. +packGSList :: [Ptr a] -> IO (Ptr (GSList (Ptr a))) +packGSList l = foldM g_slist_prepend nullPtr $ reverse l + +-- Given a GSList construct the corresponding Haskell list. +unpackGSList :: Ptr (GSList (Ptr a)) -> IO [Ptr a] +unpackGSList gsl = unpackGList (castPtr gsl) + +foreign import ccall "g_array_new" g_array_new :: + CInt -> CInt -> CUInt -> IO (Ptr (GArray ())) +foreign import ccall "g_array_set_size" g_array_set_size :: + Ptr (GArray ()) -> CUInt -> IO (Ptr (GArray ())) +foreign import ccall "g_array_unref" unrefGArray :: + Ptr (GArray a) -> IO () + +packGArray :: forall a. Storable a => [a] -> IO (Ptr (GArray a)) +packGArray elems = do + let elemsize = sizeOf (elems!!0) + array <- g_array_new 0 0 (fromIntegral elemsize) + _ <- g_array_set_size array (fromIntegral $ length elems) + dataPtr <- peek (castPtr array :: Ptr (Ptr a)) + fill dataPtr elems + return $ castPtr array + where + fill :: Ptr a -> [a] -> IO () + fill _ [] = return () + fill ptr (x:xs) = + do poke ptr x + fill (ptr `plusPtr` (sizeOf x)) xs + +unpackGArray :: forall a. Storable a => Ptr (GArray a) -> IO [a] +unpackGArray array = do + dataPtr <- peek (castPtr array :: Ptr (Ptr a)) + nitems <- peek (array `plusPtr` sizeOf dataPtr) + go dataPtr nitems + where go :: Ptr a -> Int -> IO [a] + go _ 0 = return [] + go ptr n = do + x <- peek ptr + (x:) <$> go (ptr `plusPtr` sizeOf x) (n-1) + +foreign import ccall "g_ptr_array_new" g_ptr_array_new :: + IO (Ptr (GPtrArray ())) +foreign import ccall "g_ptr_array_set_size" g_ptr_array_set_size :: + Ptr (GPtrArray ()) -> CUInt -> IO (Ptr (GPtrArray ())) +foreign import ccall "g_ptr_array_unref" unrefPtrArray :: + Ptr (GPtrArray a) -> IO () + +packGPtrArray :: [Ptr a] -> IO (Ptr (GPtrArray (Ptr a))) +packGPtrArray elems = do + array <- g_ptr_array_new + _ <- g_ptr_array_set_size array (fromIntegral $ length elems) + dataPtr <- peek (castPtr array :: Ptr (Ptr (Ptr a))) + fill dataPtr elems + return $ castPtr array + where + fill :: Ptr (Ptr a) -> [Ptr a] -> IO () + fill _ [] = return () + fill ptr (x:xs) = + do poke ptr x + fill (ptr `plusPtr` (sizeOf x)) xs + +unpackGPtrArray :: Ptr (GPtrArray (Ptr a)) -> IO [Ptr a] +unpackGPtrArray array = do + dataPtr <- peek (castPtr array :: Ptr (Ptr (Ptr a))) + nitems <- peek (array `plusPtr` sizeOf dataPtr) + go dataPtr nitems + where go :: Ptr (Ptr a) -> Int -> IO [Ptr a] + go _ 0 = return [] + go ptr n = do + x <- peek ptr + (x:) <$> go (ptr `plusPtr` sizeOf x) (n-1) + +foreign import ccall "g_byte_array_new" g_byte_array_new :: + IO (Ptr GByteArray) +foreign import ccall "g_byte_array_append" g_byte_array_append :: + Ptr GByteArray -> Ptr a -> CUInt -> IO (Ptr GByteArray) +foreign import ccall "g_byte_array_unref" unrefGByteArray :: + Ptr GByteArray -> IO () + +packGByteArray :: ByteString -> IO (Ptr GByteArray) +packGByteArray bs = do + array <- g_byte_array_new + let (ptr, offset, length) = BI.toForeignPtr bs + _ <- withForeignPtr ptr $ \dataPtr -> + g_byte_array_append array (dataPtr `plusPtr` offset) + (fromIntegral length) + return array + +unpackGByteArray :: Ptr GByteArray -> IO ByteString +unpackGByteArray array = do + dataPtr <- peek (castPtr array :: Ptr (Ptr CChar)) + length <- peek (array `plusPtr` (sizeOf dataPtr)) :: IO CUInt + B.packCStringLen (dataPtr, fromIntegral length) + +foreign import ccall "g_hash_table_new_full" g_hash_table_new_full :: + GHashFunc a -> GEqualFunc a -> GDestroyNotify a -> GDestroyNotify b -> + IO (Ptr (GHashTable a b)) +foreign import ccall "g_hash_table_insert" g_hash_table_insert :: + Ptr (GHashTable a b) -> PtrWrapped a -> PtrWrapped b -> IO #{type gboolean} + +packGHashTable :: GHashFunc a -> GEqualFunc a -> + Maybe (GDestroyNotify a) -> Maybe (GDestroyNotify b) -> + [(PtrWrapped a, PtrWrapped b)] -> IO (Ptr (GHashTable a b)) +packGHashTable keyHash keyEqual keyDestroy elemDestroy pairs = do + let keyDPtr = fromMaybe nullFunPtr keyDestroy + elemDPtr = fromMaybe nullFunPtr elemDestroy + ht <- g_hash_table_new_full keyHash keyEqual keyDPtr elemDPtr + mapM_ (uncurry (g_hash_table_insert ht)) pairs + return ht + +foreign import ccall "g_hash_table_get_keys" g_hash_table_get_keys :: + Ptr (GHashTable a b) -> IO (Ptr (GList (Ptr a))) +foreign import ccall "g_hash_table_lookup" g_hash_table_lookup :: + Ptr (GHashTable a b) -> PtrWrapped a -> IO (PtrWrapped b) +unpackGHashTable :: Ptr (GHashTable a b) -> IO [(PtrWrapped a, PtrWrapped b)] +unpackGHashTable ht = do + keysGList <- g_hash_table_get_keys ht + keys <- (map (PtrWrapped . castPtr)) <$> unpackGList keysGList + g_list_free keysGList + -- At this point we could use g_hash_table_get_values, since the + -- current implementation in GLib returns elements in the same order + -- as g_hash_table_get_keys. But to be on the safe side, since the + -- ordering is not specified in the documentation, we do the + -- following, which is (quite) slower but manifestly safe. + elems <- mapM (g_hash_table_lookup ht) keys + return (zip keys elems) + +foreign import ccall "g_hash_table_unref" unrefGHashTable :: + Ptr (GHashTable a b) -> IO () + +packByteString :: ByteString -> IO (Ptr Word8) +packByteString bs = do + let (ptr, offset, length) = BI.toForeignPtr bs + mem <- allocBytes length + withForeignPtr ptr $ \dataPtr -> + memcpy mem (dataPtr `plusPtr` offset) (fromIntegral length) + return mem + +packZeroTerminatedByteString :: ByteString -> IO (Ptr Word8) +packZeroTerminatedByteString bs = do + let (ptr, offset, length) = BI.toForeignPtr bs + mem <- allocBytes (length+1) + withForeignPtr ptr $ \dataPtr -> + memcpy mem (dataPtr `plusPtr` offset) (fromIntegral length) + poke (mem `plusPtr` (offset+length)) (0 :: Word8) + return mem + +unpackByteStringWithLength :: Integral a => a -> Ptr Word8 -> IO ByteString +unpackByteStringWithLength length ptr = + B.packCStringLen (castPtr ptr, fromIntegral length) + +unpackZeroTerminatedByteString :: Ptr Word8 -> IO ByteString +unpackZeroTerminatedByteString ptr = + B.packCString (castPtr ptr) + +packStorableArray :: Storable a => [a] -> IO (Ptr a) +packStorableArray = packMapStorableArray id + +packZeroTerminatedStorableArray :: (Num a, Storable a) => [a] -> IO (Ptr a) +packZeroTerminatedStorableArray = packMapZeroTerminatedStorableArray id + +unpackStorableArrayWithLength :: (Integral a, Storable b) => + a -> Ptr b -> IO [b] +unpackStorableArrayWithLength = unpackMapStorableArrayWithLength id + +unpackZeroTerminatedStorableArray :: (Eq a, Num a, Storable a) => + Ptr a -> IO [a] +unpackZeroTerminatedStorableArray = unpackMapZeroTerminatedStorableArray id + +packMapStorableArray :: forall a b. Storable b => (a -> b) -> [a] -> IO (Ptr b) +packMapStorableArray fn items = do + let nitems = length items + mem <- allocBytes $ (sizeOf (undefined::b)) * nitems + fill mem (map fn items) + return mem + where fill :: Ptr b -> [b] -> IO () + fill _ [] = return () + fill ptr (x:xs) = do + poke ptr x + fill (ptr `plusPtr` sizeOf x) xs + +packMapZeroTerminatedStorableArray :: forall a b. (Num b, Storable b) => + (a -> b) -> [a] -> IO (Ptr b) +packMapZeroTerminatedStorableArray fn items = do + let nitems = length items + mem <- allocBytes $ (sizeOf (undefined::b)) * (nitems+1) + fill mem (map fn items) + return mem + where fill :: Ptr b -> [b] -> IO () + fill ptr [] = poke ptr 0 + fill ptr (x:xs) = do + poke ptr x + fill (ptr `plusPtr` sizeOf x) xs + +unpackMapStorableArrayWithLength :: forall a b c. (Integral a, Storable b) => + (b -> c) -> a -> Ptr b -> IO [c] +unpackMapStorableArrayWithLength fn n ptr = map fn <$> go (fromIntegral n) ptr + where go :: Int -> Ptr b -> IO [b] + go 0 _ = return [] + go n ptr = do + x <- peek ptr + (x:) <$> go (n-1) (ptr `plusPtr` sizeOf x) + +unpackMapZeroTerminatedStorableArray :: forall a b. (Eq a, Num a, Storable a) => + (a -> b) -> Ptr a -> IO [b] +unpackMapZeroTerminatedStorableArray fn ptr = map fn <$> go ptr + where go :: Ptr a -> IO [a] + go ptr = do + x <- peek ptr + if x == 0 + then return [] + else (x:) <$> go (ptr `plusPtr` sizeOf x) + +packUTF8CArray :: [Text] -> IO (Ptr CString) +packUTF8CArray items = do + let nitems = length items + mem <- allocBytes $ nitems * (sizeOf (nullPtr :: CString)) + fill mem items + return mem + where fill :: Ptr CString -> [Text] -> IO () + fill _ [] = return () + fill ptr (x:xs) = + do cstring <- textToCString x + poke ptr cstring + fill (ptr `plusPtr` sizeOf cstring) xs + +packZeroTerminatedUTF8CArray :: [Text] -> IO (Ptr CString) +packZeroTerminatedUTF8CArray items = do + let nitems = length items + mem <- allocBytes $ (sizeOf (nullPtr :: CString)) * (nitems+1) + fill mem items + return mem + where fill :: Ptr CString -> [Text] -> IO () + fill ptr [] = poke ptr nullPtr + fill ptr (x:xs) = do cstring <- textToCString x + poke ptr cstring + fill (ptr `plusPtr` sizeOf cstring) xs + +unpackZeroTerminatedUTF8CArray :: Ptr CString -> IO [Text] +unpackZeroTerminatedUTF8CArray listPtr = go listPtr + where go :: Ptr CString -> IO [Text] + go ptr = do + cstring <- peek ptr + if cstring == nullPtr + then return [] + else (:) <$> cstringToText cstring + <*> go (ptr `plusPtr` sizeOf cstring) + +unpackUTF8CArrayWithLength :: Integral a => a -> Ptr CString -> IO [Text] +unpackUTF8CArrayWithLength n ptr = go (fromIntegral n) ptr + where go :: Int -> Ptr CString -> IO [Text] + go 0 _ = return [] + go n ptr = do + cstring <- peek ptr + (:) <$> cstringToText cstring + <*> go (n-1) (ptr `plusPtr` sizeOf cstring) + +packFileNameArray :: [String] -> IO (Ptr CString) +packFileNameArray items = do + let nitems = length items + mem <- allocBytes $ nitems * (sizeOf (nullPtr :: CString)) + fill mem items + return mem + where fill :: Ptr CString -> [String] -> IO () + fill _ [] = return () + fill ptr (x:xs) = + do cstring <- stringToCString x + poke ptr cstring + fill (ptr `plusPtr` sizeOf cstring) xs + +packZeroTerminatedFileNameArray :: [String] -> IO (Ptr CString) +packZeroTerminatedFileNameArray items = do + let nitems = length items + mem <- allocBytes $ (sizeOf (nullPtr :: CString)) * (nitems+1) + fill mem items + return mem + where fill :: Ptr CString -> [String] -> IO () + fill ptr [] = poke ptr nullPtr + fill ptr (x:xs) = do cstring <- stringToCString x + poke ptr cstring + fill (ptr `plusPtr` sizeOf cstring) xs + +unpackZeroTerminatedFileNameArray :: Ptr CString -> IO [String] +unpackZeroTerminatedFileNameArray listPtr = go listPtr + where go :: Ptr CString -> IO [String] + go ptr = do + cstring <- peek ptr + if cstring == nullPtr + then return [] + else (:) <$> cstringToString cstring + <*> go (ptr `plusPtr` sizeOf cstring) + +unpackFileNameArrayWithLength :: Integral a => + a -> Ptr CString -> IO [String] +unpackFileNameArrayWithLength n ptr = go (fromIntegral n) ptr + where go :: Int -> Ptr CString -> IO [String] + go 0 _ = return [] + go n ptr = do + cstring <- peek ptr + (:) <$> cstringToString cstring + <*> go (n-1) (ptr `plusPtr` sizeOf cstring) + +foreign import ccall "g_strdup" g_strdup :: CString -> IO CString + +-- We need to use the GLib allocator for constructing CStrings, since +-- the ownership of the string may be transferred to the GLib side, +-- which will free it with g_free. +stringToCString :: String -> IO CString +stringToCString str = withCString str g_strdup + +cstringToString :: CString -> IO String +cstringToString = peekCString + +foreign import ccall "g_strndup" g_strndup :: + CString -> #{type gsize} -> IO CString + +-- | Convert `Text` into a `CString`, using the GLib allocator. +textToCString :: Text -> IO CString +textToCString str = TF.withCStringLen str $ \(cstr, len) -> + -- Because withCStringLen returns NULL for a zero-length Text, and + -- g_strndup returns NULL for NULL, even if n==0. + if cstr /= nullPtr + then g_strndup cstr (fromIntegral len) + else callocBytes 1 + +withTextCString :: Text -> (CString -> IO a) -> IO a +withTextCString text action = bracket (textToCString text) freeMem action + +foreign import ccall "strlen" c_strlen :: + CString -> IO (CSize) + +cstringToText :: CString -> IO Text +cstringToText cstr = do + len <- c_strlen cstr + let cstrlen = (cstr, fromIntegral len) + TF.peekCStringLen cstrlen + +byteStringToCString :: ByteString -> IO CString +byteStringToCString bs = B.useAsCString bs g_strdup + +cstringToByteString :: CString -> IO ByteString +cstringToByteString = B.packCString + +packPtrArray :: [Ptr a] -> IO (Ptr (Ptr a)) +packPtrArray items = do + let nitems = length items + mem <- allocBytes $ (sizeOf (nullPtr :: Ptr a)) * nitems + fill mem items + return mem + where fill :: Ptr (Ptr a) -> [Ptr a] -> IO () + fill _ [] = return () + fill ptr (x:xs) = do poke ptr x + fill (ptr `plusPtr` sizeOf x) xs + +packZeroTerminatedPtrArray :: [Ptr a] -> IO (Ptr (Ptr a)) +packZeroTerminatedPtrArray items = do + let nitems = length items + mem <- allocBytes $ (sizeOf (nullPtr :: Ptr a)) * (nitems+1) + fill mem items + return mem + where fill :: Ptr (Ptr a) -> [Ptr a] -> IO () + fill ptr [] = poke ptr nullPtr + fill ptr (x:xs) = do poke ptr x + fill (ptr `plusPtr` sizeOf x) xs + +unpackPtrArrayWithLength :: Integral a => a -> Ptr (Ptr b) -> IO [Ptr b] +unpackPtrArrayWithLength n ptr = go (fromIntegral n) ptr + where go :: Int -> Ptr (Ptr a) -> IO [Ptr a] + go 0 _ = return [] + go n ptr = (:) <$> peek ptr + <*> go (n-1) (ptr `plusPtr` sizeOf (nullPtr :: Ptr a)) + +unpackZeroTerminatedPtrArray :: Ptr (Ptr a) -> IO [Ptr a] +unpackZeroTerminatedPtrArray ptr = go ptr + where go :: Ptr (Ptr a) -> IO [Ptr a] + go ptr = do + p <- peek ptr + if p == nullPtr + then return [] + else (p:) <$> go (ptr `plusPtr` sizeOf p) + +mapZeroTerminatedCArray :: (Ptr a -> IO b) -> Ptr (Ptr a) -> IO () +mapZeroTerminatedCArray f dataPtr + | (dataPtr == nullPtr) = return () + | otherwise = + do ptr <- peek dataPtr + if ptr == nullPtr + then return () + else do + _ <- f ptr + mapZeroTerminatedCArray f (dataPtr `plusPtr` sizeOf ptr) + +packBlockArray :: Int -> [Ptr a] -> IO (Ptr a) +packBlockArray size items = do + let nitems = length items + mem <- allocBytes $ size * nitems + fill mem items + return mem + where fill :: Ptr a -> [Ptr a] -> IO () + fill _ [] = return () + fill ptr (x:xs) = do memcpy ptr x size + fill (ptr `plusPtr` size) xs + +foreign import ccall "g_memdup" g_memdup :: + Ptr a -> CUInt -> IO (Ptr a) + +unpackBlockArrayWithLength :: Integral a => Int -> a -> Ptr b -> IO [Ptr b] +unpackBlockArrayWithLength size n ptr = go size (fromIntegral n) ptr + where go :: Int -> Int -> Ptr b -> IO [Ptr b] + go _ 0 _ = return [] + go size n ptr = do + buf <- g_memdup ptr (fromIntegral size) + (buf :) <$> go size (n-1) (ptr `plusPtr` size) + +unpackBoxedArrayWithLength :: forall a b. (Integral a, BoxedObject b) => + Int -> a -> Ptr b -> IO [Ptr b] +unpackBoxedArrayWithLength size n ptr = go size (fromIntegral n) ptr + where go :: Int -> Int -> Ptr b -> IO [Ptr b] + go _ 0 _ = return [] + go size n ptr = do + buf <- copyBoxedPtr ptr + (buf :) <$> go size (n-1) (ptr `plusPtr` size) + +mapCArrayWithLength :: (Storable a, Integral b) => + b -> (a -> IO c) -> Ptr a -> IO () +mapCArrayWithLength n f dataPtr + | (dataPtr == nullPtr) = return () + | (n <= 0) = return () + | otherwise = + do ptr <- peek dataPtr + _ <- f ptr + mapCArrayWithLength (n-1) f (dataPtr `plusPtr` sizeOf ptr) + +mapGArray :: forall a b. Storable a => (a -> IO b) -> Ptr (GArray a) -> IO () +mapGArray f array + | (array == nullPtr) = return () + | otherwise = + do dataPtr <- peek (castPtr array :: Ptr (Ptr a)) + nitems <- peek (array `plusPtr` sizeOf dataPtr) + go dataPtr nitems + where go :: Ptr a -> Int -> IO () + go _ 0 = return () + go ptr n = do + x <- peek ptr + _ <- f x + go (ptr `plusPtr` sizeOf x) (n-1) + +mapPtrArray :: (Ptr a -> IO b) -> Ptr (GPtrArray (Ptr a)) -> IO () +mapPtrArray f array = mapGArray f (castPtr array) + +mapGList :: (Ptr a -> IO b) -> Ptr (GList (Ptr a)) -> IO () +mapGList f glist + | (glist == nullPtr) = return () + | otherwise = + do ptr <- peek (castPtr glist) + next <- peek (glist `plusPtr` sizeOf ptr) + _ <- f ptr + mapGList f next + +mapGSList :: (Ptr a -> IO b) -> Ptr (GSList (Ptr a)) -> IO () +mapGSList f gslist = mapGList f (castPtr gslist) diff --git a/src/Data/GI/Base/BasicTypes.hsc b/src/Data/GI/Base/BasicTypes.hsc new file mode 100644 --- /dev/null +++ b/src/Data/GI/Base/BasicTypes.hsc @@ -0,0 +1,194 @@ +{-# LANGUAGE ConstraintKinds, FlexibleContexts, FlexibleInstances #-} +-- | Basic types used in the bindings. +module Data.GI.Base.BasicTypes + ( + -- * GType related + GType(..) + , CGType + + , gtypeName + + , gtypeString + , gtypePointer + , gtypeInt32 + , gtypeUInt32 + , gtypeInt64 + , gtypeUInt64 + , gtypeFloat + , gtypeDouble + , gtypeBoolean + , gtypeGType + , gtypeStrv + , gtypeBoxed + , gtypeObject + + -- * Memory management + + , ForeignPtrNewtype + , BoxedObject(..) + , BoxedEnum(..) + , GObject(..) + + -- * Basic GLib \/ GObject types + , GVariant(..) + , GParamSpec(..) + + , GArray(..) + , GPtrArray(..) + , GByteArray(..) + , GHashTable(..) + , GList(..) + , g_list_free + , GSList(..) + , g_slist_free + + , IsGFlag + + , PtrWrapped(..) + , GDestroyNotify + ) where + +import Data.Coerce (Coercible) +import Data.Word +import Foreign.Ptr (Ptr, FunPtr) +import Foreign.ForeignPtr (ForeignPtr) +import Foreign.C.String (CString, peekCString) + +#include + +-- | A type identifier in the GLib type system. This is the low-level +-- type associated with the representation in memory, when using this +-- on the Haskell side use `GType` below. +type CGType = #type GType + +-- | A newtype for use on the haskell side. +newtype GType = GType {gtypeToCGType :: CGType} + +foreign import ccall "g_type_name" g_type_name :: GType -> IO CString + +-- | Get the name assigned to the given `GType`. +gtypeName :: GType -> IO String +gtypeName gtype = g_type_name gtype >>= peekCString + +-- | `GType` of strings. +gtypeString :: GType +gtypeString = GType #const G_TYPE_STRING + +-- | `GType` of pointers. +gtypePointer :: GType +gtypePointer = GType #const G_TYPE_POINTER + +-- | `GType` for signed integers. +gtypeInt32 :: GType +gtypeInt32 = GType #const G_TYPE_INT + +-- | `GType` for unsigned integers. +gtypeUInt32 :: GType +gtypeUInt32 = GType #const G_TYPE_UINT + +-- | `GType` for signed 64 bit integers. +gtypeInt64 :: GType +gtypeInt64 = GType #const G_TYPE_INT64 + +-- | `GType` for unsigned 64 bit integers. +gtypeUInt64 :: GType +gtypeUInt64 = GType #const G_TYPE_UINT64 + +-- | `GType` for floating point values. +gtypeFloat :: GType +gtypeFloat = GType #const G_TYPE_FLOAT + +-- | `GType` for gdouble. +gtypeDouble :: GType +gtypeDouble = GType #const G_TYPE_DOUBLE + +-- | `GType` corresponding to gboolean. +gtypeBoolean :: GType +gtypeBoolean = GType #const G_TYPE_BOOLEAN + +-- | `GType` corresponding to a `GType` itself. +gtypeGType :: GType +gtypeGType = GType #const G_TYPE_GTYPE + +-- | `GType` for a NULL terminated array of strings. +gtypeStrv :: GType +gtypeStrv = GType #const G_TYPE_STRV + +-- | `GType` corresponding to a `BoxedObject`. +gtypeBoxed :: GType +gtypeBoxed = GType #const G_TYPE_BOXED + +-- | `GType` corresponding to a `GObject`. +gtypeObject :: GType +gtypeObject = GType #const G_TYPE_OBJECT + +-- | A constraint ensuring that the given type is coercible to a +-- ForeignPtr. It will hold for newtypes of the form +-- +-- > newtype Foo = Foo (ForeignPtr Foo) +-- +-- which is the typical shape of wrapped 'GObject's. +type ForeignPtrNewtype a = Coercible a (ForeignPtr ()) +-- Notice that the Coercible here is to ForeignPtr (), instead of +-- "ForeignPtr a", which would be the most natural thing. Both are +-- representationally equivalent, so this is not a big deal. This is +-- to work around a problem in ghc 7.10: +-- https://ghc.haskell.org/trac/ghc/ticket/10715 + +-- | Wrapped boxed structures, identified by their `GType`. +class ForeignPtrNewtype a => BoxedObject a where + boxedType :: a -> IO GType -- This should not use the value of its + -- argument. + +-- | Enums with an associated `GType`. +class BoxedEnum a where + boxedEnumType :: a -> IO GType + +-- | A wrapped `GObject`. +class ForeignPtrNewtype a => GObject a where + -- | Whether the `GObject` is a descendent of . + gobjectIsInitiallyUnowned :: a -> Bool + -- | The `GType` for this object. + gobjectType :: a -> IO GType + +-- | A . See "Data.GI.Base.GVariant" for further methods. +newtype GVariant = GVariant (ForeignPtr GVariant) + +-- | A . See "Data.GI.Base.GParamSpec" for further methods. +newtype GParamSpec = GParamSpec (ForeignPtr GParamSpec) + +-- | An enum usable as a flag for a function. +class Enum a => IsGFlag a + +-- | A . Marshalling for this type is done in "Data.GI.Base.BasicConversions", it is mapped to a list on the Haskell side. +data GArray a = GArray (Ptr (GArray a)) + +-- | A . Marshalling for this type is done in "Data.GI.Base.BasicConversions", it is mapped to a list on the Haskell side. +data GPtrArray a = GPtrArray (Ptr (GPtrArray a)) + +-- | A . Marshalling for this type is done in "Data.GI.Base.BasicConversions", it is packed to a 'Data.ByteString.ByteString' on the Haskell side. +data GByteArray = GByteArray (Ptr GByteArray) + +-- | A . It is mapped to a 'Data.Map.Map' on the Haskell side. +data GHashTable a b = GHashTable (Ptr (GHashTable a b)) + +-- | A , mapped to a list on the Haskell side. Marshalling is done in "Data.GI.Base.BasicConversions". +data GList a = GList (Ptr (GList a)) + +-- | A , mapped to a list on the Haskell side. Marshalling is done in "Data.GI.Base.BasicConversions". +data GSList a = GSList (Ptr (GSList a)) + +-- | Some APIs, such as `GHashTable`, pass around scalar types +-- wrapped into a pointer. We encode such a type as follows. +newtype PtrWrapped a = PtrWrapped {unwrapPtr :: Ptr a} + +-- | Destroy the memory associated with a given pointer. +type GDestroyNotify a = FunPtr (Ptr a -> IO ()) + +-- | Free the given 'GList'. +foreign import ccall "g_list_free" g_list_free :: + Ptr (GList a) -> IO () + +-- | Free the given 'GSList'. +foreign import ccall "g_slist_free" g_slist_free :: + Ptr (GSList a) -> IO () diff --git a/src/Data/GI/Base/Closure.hs b/src/Data/GI/Base/Closure.hs new file mode 100644 --- /dev/null +++ b/src/Data/GI/Base/Closure.hs @@ -0,0 +1,41 @@ +-- Some helper functions to create closures. +module Data.GI.Base.Closure + ( Closure(..) + , newCClosure + , noClosure + ) where + +import Foreign + +import Data.GI.Base.BasicTypes +import Data.GI.Base.ManagedPtr (wrapBoxed) +import Data.GI.Base.Utils (safeFreeFunPtrPtr) + +newtype Closure = Closure (ForeignPtr Closure) + +noClosure :: Maybe Closure +noClosure = Nothing + +foreign import ccall "g_closure_get_type" c_g_closure_get_type :: + IO GType + +instance BoxedObject Closure where + boxedType _ = c_g_closure_get_type + + +foreign import ccall "g_cclosure_new" g_cclosure_new + :: FunPtr a -> Ptr () -> FunPtr c -> IO (Ptr Closure) + +foreign import ccall "g_closure_ref" g_closure_ref + :: Ptr Closure -> IO (Ptr Closure) + +foreign import ccall "g_closure_sink" g_closure_sink + :: Ptr Closure -> IO () + +newCClosure :: FunPtr a -> IO Closure +newCClosure ptr = do + closure <- g_cclosure_new ptr nullPtr safeFreeFunPtrPtr + -- The Haskell runtime will manage the memory associated to the + -- closure, so ref and sink to let GLib know this. + g_closure_ref closure >>= g_closure_sink + wrapBoxed Closure closure diff --git a/src/Data/GI/Base/GError.chs b/src/Data/GI/Base/GError.chs new file mode 100644 --- /dev/null +++ b/src/Data/GI/Base/GError.chs @@ -0,0 +1,238 @@ +{-# LANGUAGE DeriveDataTypeable, ScopedTypeVariables #-} + +-- | To catch GError exceptions use the +-- catchGError* or handleGError* functions. They work in a similar +-- way to the standard 'Control.Exception.catch' and +-- 'Control.Exception.handle' functions. +-- +-- To catch just a single specific error use 'catchGErrorJust' \/ +-- 'handleGErrorJust'. To catch any error in a particular error domain +-- use 'catchGErrorJustDomain' \/ 'handleGErrorJustDomain' +-- +-- For convenience, generated code also includes specialized variants +-- of 'catchGErrorJust' \/ 'handleGErrorJust' for each error type. For +-- example, for errors of type 'GI.GdkPixbuf.PixbufError' one could +-- invoke 'GI.GdkPixbuf.catchPixbufError' \/ +-- 'GI.GdkPixbuf.handlePixbufError'. The definition is simply +-- +-- > catchPixbufError :: IO a -> (PixbufError -> GErrorMessage -> IO a) -> IO a +-- > catchPixbufError = catchGErrorJustDomain +-- +-- Notice that the type is suitably specialized, so only +-- errors of type 'GI.GdkPixbuf.PixbufError' will be caught. +module Data.GI.Base.GError + ( + -- * Unpacking GError + -- + GError(..) + , gerrorDomain + , gerrorCode + , gerrorMessage + + , GErrorDomain + , GErrorCode + , GErrorMessage + + -- * Catching GError exceptions + , catchGErrorJust + , catchGErrorJustDomain + + , handleGErrorJust + , handleGErrorJustDomain + + -- * Creating new 'GError's + , gerrorNew + + -- * Implementation specific details + -- | The following are used in the implementation + -- of the bindings, and are in general not necessary for using the + -- API. + , GErrorClass(..) + + , propagateGError + , checkGError + + ) where + +#if __GLASGOW_HASKELL__ < 710 +import Control.Applicative ((<$>)) +#endif + +import Foreign (poke, peek) +import Foreign.ForeignPtr (ForeignPtr, withForeignPtr) +import Foreign.Ptr (Ptr, plusPtr, nullPtr) +import Foreign.C +import Control.Exception +import Data.Text (Text) +import Data.Typeable (Typeable) + +import Data.GI.Base.BasicTypes (BoxedObject(..), GType(..)) +import Data.GI.Base.BasicConversions (withTextCString, cstringToText) +import Data.GI.Base.ManagedPtr (wrapBoxed) +import Data.GI.Base.Utils (allocMem, freeMem) + +#include + +-- | A GError, consisting of a domain, code and a human readable +-- message. These can be accessed by 'gerrorDomain', 'gerrorCode' and +-- 'gerrorMessage' below. +newtype GError = GError (ForeignPtr GError) + deriving (Typeable, Show) + +instance Exception GError + +foreign import ccall "g_error_get_type" g_error_get_type :: IO GType + +instance BoxedObject GError where + boxedType _ = g_error_get_type + +-- | A GQuark. +type GQuark = {# type GQuark #} + +-- | A code used to identify the "namespace" of the error. Within each error +-- domain all the error codes are defined in an enumeration. Each gtk\/gnome +-- module that uses GErrors has its own error domain. The rationale behind +-- using error domains is so that each module can organise its own error codes +-- without having to coordinate on a global error code list. +type GErrorDomain = GQuark + +-- | A code to identify a specific error within a given 'GErrorDomain'. Most of +-- time you will not need to deal with this raw code since there is an +-- enumeration type for each error domain. Of course which enumeration to use +-- depends on the error domain, but if you use 'catchGErrorJustDomain' or +-- 'handleGErrorJustDomain', this is worked out for you automatically. +type GErrorCode = {# type gint #} + +-- | A human readable error message. +type GErrorMessage = Text + +foreign import ccall "g_error_new_literal" g_error_new_literal :: + GQuark -> GErrorCode -> CString -> IO (Ptr GError) + +-- | Create a new 'GError'. +gerrorNew :: GErrorDomain -> GErrorCode -> GErrorMessage -> IO GError +gerrorNew domain code message = + withTextCString message $ \cstring -> + g_error_new_literal domain code cstring >>= wrapBoxed GError + +-- | Return the domain for the given `GError`. This is a GQuark, a +-- textual representation can be obtained with +-- `GI.GLib.quarkToString`. +gerrorDomain :: GError -> IO GQuark +gerrorDomain (GError fptr) = + withForeignPtr fptr $ \ptr -> + peek $ ptr `plusPtr` {# offsetof GError->domain #} + +-- | The numeric code for the given `GError`. +gerrorCode :: GError -> IO GErrorCode +gerrorCode (GError fptr) = + withForeignPtr fptr $ \ptr -> + peek $ ptr `plusPtr` {# offsetof GError->code #} + +-- | A text message describing the `GError`. +gerrorMessage :: GError -> IO GErrorMessage +gerrorMessage (GError fptr) = + withForeignPtr fptr $ \ptr -> + (peek $ ptr `plusPtr` {# offsetof GError->message #}) >>= cstringToText + +-- | Each error domain's error enumeration type should be an instance of this +-- class. This class helps to hide the raw error and domain codes from the +-- user. +-- +-- Example for 'GI.GdkPixbuf.PixbufError': +-- +-- > instance GErrorClass PixbufError where +-- > gerrorClassDomain _ = "gdk-pixbuf-error-quark" +-- +class Enum err => GErrorClass err where + gerrorClassDomain :: err -> Text -- ^ This must not use the value of its + -- parameter so that it is safe to pass + -- 'undefined'. + +foreign import ccall unsafe "g_quark_try_string" g_quark_try_string :: + CString -> IO GQuark + +-- | Given the string representation of an error domain returns the +-- corresponding error quark. +gErrorQuarkFromDomain :: Text -> IO GQuark +gErrorQuarkFromDomain domain = withTextCString domain g_quark_try_string + +-- | This will catch just a specific GError exception. If you need to catch a +-- range of related errors, 'catchGErrorJustDomain' is probably more +-- appropriate. Example: +-- +-- > do image <- catchGErrorJust PixbufErrorCorruptImage +-- > loadImage +-- > (\errorMessage -> do log errorMessage +-- > return mssingImagePlaceholder) +-- +catchGErrorJust :: GErrorClass err => err -- ^ The error to catch + -> IO a -- ^ The computation to run + -> (GErrorMessage -> IO a) -- ^ Handler to invoke if + -- an exception is raised + -> IO a +catchGErrorJust code action handler = do + domainQuark <- gErrorQuarkFromDomain $ gerrorClassDomain code + catch action (handler' domainQuark) + where handler' quark gerror = do + domain <- gerrorDomain gerror + code' <- gerrorCode gerror + if domain == quark && code' == (fromIntegral . fromEnum) code + then gerrorMessage gerror >>= handler + else throw gerror -- Pass it on + +-- | Catch all GErrors from a particular error domain. The handler function +-- should just deal with one error enumeration type. If you need to catch +-- errors from more than one error domain, use this function twice with an +-- appropriate handler functions for each. +-- +-- > catchGErrorJustDomain +-- > loadImage +-- > (\err message -> case err of +-- > PixbufErrorCorruptImage -> ... +-- > PixbufErrorInsufficientMemory -> ... +-- > PixbufErrorUnknownType -> ... +-- > _ -> ...) +-- +catchGErrorJustDomain :: forall err a. GErrorClass err => + IO a -- ^ The computation to run + -> (err -> GErrorMessage -> IO a) -- ^ Handler to invoke if an exception is raised + -> IO a +catchGErrorJustDomain action handler = do + domainQuark <- gErrorQuarkFromDomain $ gerrorClassDomain (undefined::err) + catch action (handler' domainQuark) + where handler' quark gerror = do + domain <- gerrorDomain gerror + if domain == quark + then do + code <- (toEnum . fromIntegral) <$> gerrorCode gerror + msg <- gerrorMessage gerror + handler code msg + else throw gerror + +-- | A verson of 'handleGErrorJust' with the arguments swapped around. +handleGErrorJust :: GErrorClass err => err -> (GErrorMessage -> IO a) -> IO a -> IO a +handleGErrorJust code = flip (catchGErrorJust code) + +-- | A verson of 'catchGErrorJustDomain' with the arguments swapped around. +handleGErrorJustDomain :: GErrorClass err => (err -> GErrorMessage -> IO a) -> IO a -> IO a +handleGErrorJustDomain = flip catchGErrorJustDomain + +-- | Run the given function catching possible 'GError's in its +-- execution. If a 'GError' is emitted this throws the corresponding +-- exception. +propagateGError :: (Ptr (Ptr GError) -> IO a) -> IO a +propagateGError f = checkGError f throw + +-- | Like 'propagateGError', but allows to specify a custom handler +-- instead of just throwing the exception. +checkGError :: (Ptr (Ptr GError) -> IO a) -> (GError -> IO a) -> IO a +checkGError f handler = do + gerrorPtr <- allocMem + poke gerrorPtr nullPtr + result <- f gerrorPtr + gerror <- peek gerrorPtr + freeMem gerrorPtr + if gerror /= nullPtr + then wrapBoxed GError gerror >>= handler + else return result diff --git a/src/Data/GI/Base/GHashTable.hsc b/src/Data/GI/Base/GHashTable.hsc new file mode 100644 --- /dev/null +++ b/src/Data/GI/Base/GHashTable.hsc @@ -0,0 +1,68 @@ +{- | Machinery for some basic support of `GHashTable`. + +The GLib `GHashTable` implementation requires two things: we need to +"pack" a datatype into a pointer (for datatypes that are represented +by pointers this is the trivial operation, for integers it is not, and +GLib has some helper macros). + +We also need to be able to hash and check for equality different +datatypes. +-} +module Data.GI.Base.GHashTable + ( GHashFunc + , GEqualFunc + + , gDirectHash + , gDirectEqual + , ptrPackPtr + , ptrUnpackPtr + + , gStrHash + , gStrEqual + , cstringPackPtr + , cstringUnpackPtr + ) where + +import Data.Int +import Data.Word + +import Foreign.C +import Foreign.Ptr (Ptr, castPtr, FunPtr) + +import Data.GI.Base.BasicTypes (PtrWrapped(..)) + +#include + +-- | A pointer to a hashing function on the C side. +type GHashFunc a = FunPtr (PtrWrapped a -> IO #{type guint}) + +-- | A pointer to an equality checking function on the C side. +type GEqualFunc a = FunPtr (PtrWrapped a -> PtrWrapped a -> IO #{type gboolean}) + +-- | Compute the hash for a `Ptr`. +foreign import ccall "&g_direct_hash" gDirectHash :: GHashFunc (Ptr a) + +-- | Check whether two pointers are equal. +foreign import ccall "&g_direct_equal" gDirectEqual :: GEqualFunc (Ptr a) + +-- | Pack a `Ptr` into a `PtrWrapped` `Ptr`. +ptrPackPtr :: Ptr a -> PtrWrapped (Ptr a) +ptrPackPtr = PtrWrapped . castPtr + +-- | Extract a `Ptr` from a `PtrWrapped` `Ptr`. +ptrUnpackPtr :: PtrWrapped (Ptr a) -> Ptr a +ptrUnpackPtr = castPtr . unwrapPtr + +-- | Compute the hash for a `CString`. +foreign import ccall "&g_str_hash" gStrHash :: GHashFunc CString + +-- | Check whether two `CString`s are equal. +foreign import ccall "&g_str_equal" gStrEqual :: GEqualFunc CString + +-- | Pack a `CString` into a `Ptr` than can go into a `GHashTable`. +cstringPackPtr :: CString -> PtrWrapped CString +cstringPackPtr = ptrPackPtr + +-- | Extract a `CString` wrapped into a `Ptr` coming from a `GHashTable`. +cstringUnpackPtr :: PtrWrapped CString -> CString +cstringUnpackPtr = ptrUnpackPtr diff --git a/src/Data/GI/Base/GParamSpec.hsc b/src/Data/GI/Base/GParamSpec.hsc new file mode 100644 --- /dev/null +++ b/src/Data/GI/Base/GParamSpec.hsc @@ -0,0 +1,50 @@ +module Data.GI.Base.GParamSpec + ( noGParamSpec + + , wrapGParamSpecPtr + , newGParamSpecFromPtr + , refGParamSpec + , unrefGParamSpec + ) where + +import Foreign.Ptr +import Foreign.ForeignPtr +import Control.Monad (void) + +import Data.GI.Base.BasicTypes (GParamSpec(..)) + +#include + +noGParamSpec :: Maybe GParamSpec +noGParamSpec = Nothing + +foreign import ccall "g_param_spec_ref_sink" g_param_spec_ref_sink :: + Ptr GParamSpec -> IO (Ptr GParamSpec) +foreign import ccall "g_param_spec_ref" g_param_spec_ref :: + Ptr GParamSpec -> IO (Ptr GParamSpec) +foreign import ccall "g_param_spec_unref" g_param_spec_unref :: + Ptr GParamSpec -> IO () +foreign import ccall "&g_param_spec_unref" ptr_to_g_param_spec_unref :: + FunPtr (Ptr GParamSpec -> IO ()) + +-- | Take ownership of a ParamSpec passed in 'Ptr'. +wrapGParamSpecPtr :: Ptr GParamSpec -> IO GParamSpec +wrapGParamSpecPtr ptr = do + void $ g_param_spec_ref_sink ptr + fPtr <- newForeignPtr ptr_to_g_param_spec_unref ptr + return $! GParamSpec fPtr + +-- | Construct a Haskell wrapper for the given 'GParamSpec', without +-- assuming ownership. +newGParamSpecFromPtr :: Ptr GParamSpec -> IO GParamSpec +newGParamSpecFromPtr ptr = do + fPtr <- g_param_spec_ref ptr >>= newForeignPtr ptr_to_g_param_spec_unref + return $! GParamSpec fPtr + +-- | Add a reference to the given 'GParamSpec'. +refGParamSpec :: GParamSpec -> IO (Ptr GParamSpec) +refGParamSpec (GParamSpec fptr) = withForeignPtr fptr g_param_spec_ref + +-- | Remove a reference to the given 'GParamSpec'. +unrefGParamSpec :: GParamSpec -> IO () +unrefGParamSpec (GParamSpec fptr) = withForeignPtr fptr g_param_spec_unref diff --git a/src/Data/GI/Base/GValue.hsc b/src/Data/GI/Base/GValue.hsc new file mode 100644 --- /dev/null +++ b/src/Data/GI/Base/GValue.hsc @@ -0,0 +1,307 @@ +{-# LANGUAGE FlexibleInstances #-} +module Data.GI.Base.GValue + ( GValue(..) + + , IsGValue(..) + + , newGValue -- Build a new, empty, GValue of the given type + , buildGValue -- Build a new GValue and initialize to the given value + , noGValue + + , set_string + , get_string + , set_pointer + , get_pointer + , set_int32 + , get_int32 + , set_uint32 + , get_uint32 + , set_int64 + , get_int64 + , set_uint64 + , get_uint64 + , set_float + , get_float + , set_double + , get_double + , set_boolean + , get_boolean + , set_gtype + , get_gtype + , set_object + , get_object + , set_boxed + , get_boxed + , set_variant + , get_variant + , set_enum + , get_enum + , set_flags + , get_flags + ) where + +#include + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative ((<$>)) +#endif +import Control.Monad ((>=>)) + +import Data.Word +import Data.Int +import Data.Text (Text, pack, unpack) + +import Foreign.C.Types (CInt(..), CUInt(..), CFloat(..), CDouble(..)) +import Foreign.C.String (CString) +import Foreign.Ptr (Ptr) +import Foreign.ForeignPtr (ForeignPtr) + +import Data.GI.Base.BasicTypes +import Data.GI.Base.BasicConversions (cstringToText, textToCString) +import Data.GI.Base.ManagedPtr +import Data.GI.Base.Utils (callocBytes, freeMem) + +newtype GValue = GValue (ForeignPtr GValue) + +noGValue :: Maybe GValue +noGValue = Nothing + +foreign import ccall unsafe "g_value_get_type" c_g_value_get_type :: + IO CGType + +instance BoxedObject GValue where + boxedType _ = GType <$> c_g_value_get_type + +foreign import ccall "g_value_init" g_value_init :: + Ptr GValue -> CGType -> IO (Ptr GValue) + +newGValue :: GType -> IO GValue +newGValue (GType gtype) = do + gvptr <- callocBytes #size GValue + _ <- g_value_init gvptr gtype + gv <- wrapBoxed GValue gvptr + return $! gv + +-- Build a new GValue and set the initial value, just for convenience +buildGValue :: GType -> (GValue -> a -> IO ()) -> a -> IO GValue +buildGValue gtype setter val = do + gv <- newGValue gtype + setter gv val + return gv + +class IsGValue a where + toGValue :: a -> IO GValue + fromGValue :: GValue -> IO a + +instance IsGValue String where + toGValue = buildGValue gtypeString set_string . pack + fromGValue v = unpack <$> get_string v + +instance IsGValue Text where + toGValue = buildGValue gtypeString set_string + fromGValue = get_string + +instance IsGValue (Ptr a) where + toGValue = buildGValue gtypePointer set_pointer + fromGValue = get_pointer + +instance IsGValue Int32 where + toGValue = buildGValue gtypeInt32 set_int32 + fromGValue = get_int32 + +instance IsGValue Word32 where + toGValue = buildGValue gtypeUInt32 set_uint32 + fromGValue = get_uint32 + +instance IsGValue Int64 where + toGValue = buildGValue gtypeInt64 set_int64 + fromGValue = get_int64 + +instance IsGValue Word64 where + toGValue = buildGValue gtypeUInt64 set_uint64 + fromGValue = get_uint64 + +instance IsGValue Float where + toGValue = buildGValue gtypeFloat set_float + fromGValue = get_float + +instance IsGValue Double where + toGValue = buildGValue gtypeDouble set_double + fromGValue = get_double + +instance IsGValue Bool where + toGValue = buildGValue gtypeBoolean set_boolean + fromGValue = get_boolean + +instance IsGValue GType where + toGValue = buildGValue gtypeGType set_gtype + fromGValue = get_gtype + +foreign import ccall "g_value_set_string" _set_string :: + Ptr GValue -> CString -> IO () +foreign import ccall "g_value_get_string" _get_string :: + Ptr GValue -> IO CString + +set_string :: GValue -> Text -> IO () +set_string gv str = withManagedPtr gv $ \ptr -> do + cstr <- textToCString str + _set_string ptr cstr + freeMem cstr + +get_string :: GValue -> IO Text +get_string gv = withManagedPtr gv $ _get_string >=> cstringToText + +foreign import ccall unsafe "g_value_set_pointer" _set_pointer :: + Ptr GValue -> Ptr a -> IO () +foreign import ccall unsafe "g_value_get_pointer" _get_pointer :: + Ptr GValue -> IO (Ptr b) + +set_pointer :: GValue -> Ptr a -> IO () +set_pointer gv ptr = withManagedPtr gv $ flip _set_pointer ptr + +get_pointer :: GValue -> IO (Ptr b) +get_pointer gv = withManagedPtr gv _get_pointer + +foreign import ccall unsafe "g_value_set_int" _set_int32 :: + Ptr GValue -> Int32 -> IO () +foreign import ccall unsafe "g_value_get_int" _get_int32 :: + Ptr GValue -> IO Int32 + +set_int32 :: GValue -> Int32 -> IO () +set_int32 gv n = withManagedPtr gv $ flip _set_int32 n + +get_int32 :: GValue -> IO Int32 +get_int32 gv = withManagedPtr gv _get_int32 + +foreign import ccall unsafe "g_value_set_uint" _set_uint32 :: + Ptr GValue -> Word32 -> IO () +foreign import ccall unsafe "g_value_get_uint" _get_uint32 :: + Ptr GValue -> IO Word32 + +set_uint32 :: GValue -> Word32 -> IO () +set_uint32 gv n = withManagedPtr gv $ flip _set_uint32 n + +get_uint32 :: GValue -> IO Word32 +get_uint32 gv = withManagedPtr gv _get_uint32 + +foreign import ccall unsafe "g_value_set_int64" _set_int64 :: + Ptr GValue -> Int64 -> IO () +foreign import ccall unsafe "g_value_get_int64" _get_int64 :: + Ptr GValue -> IO Int64 + +set_int64 :: GValue -> Int64 -> IO () +set_int64 gv n = withManagedPtr gv $ flip _set_int64 n + +get_int64 :: GValue -> IO Int64 +get_int64 gv = withManagedPtr gv _get_int64 + +foreign import ccall unsafe "g_value_set_uint64" _set_uint64 :: + Ptr GValue -> Word64 -> IO () +foreign import ccall unsafe "g_value_get_uint64" _get_uint64 :: + Ptr GValue -> IO Word64 + +set_uint64 :: GValue -> Word64 -> IO () +set_uint64 gv n = withManagedPtr gv $ flip _set_uint64 n + +get_uint64 :: GValue -> IO Word64 +get_uint64 gv = withManagedPtr gv _get_uint64 + +foreign import ccall unsafe "g_value_set_float" _set_float :: + Ptr GValue -> CFloat -> IO () +foreign import ccall unsafe "g_value_get_float" _get_float :: + Ptr GValue -> IO CFloat + +set_float :: GValue -> Float -> IO () +set_float gv f = withManagedPtr gv $ flip _set_float (realToFrac f) + +get_float :: GValue -> IO Float +get_float gv = realToFrac <$> withManagedPtr gv _get_float + +foreign import ccall unsafe "g_value_set_double" _set_double :: + Ptr GValue -> CDouble -> IO () +foreign import ccall unsafe "g_value_get_double" _get_double :: + Ptr GValue -> IO CDouble + +set_double :: GValue -> Double -> IO () +set_double gv d = withManagedPtr gv $ flip _set_double (realToFrac d) + +get_double :: GValue -> IO Double +get_double gv = realToFrac <$> withManagedPtr gv _get_double + +foreign import ccall unsafe "g_value_set_boolean" _set_boolean :: + Ptr GValue -> CInt -> IO () +foreign import ccall unsafe "g_value_get_boolean" _get_boolean :: + Ptr GValue -> IO CInt + +set_boolean :: GValue -> Bool -> IO () +set_boolean gv b = withManagedPtr gv $ \ptr -> + _set_boolean ptr (fromIntegral $ fromEnum b) + +get_boolean :: GValue -> IO Bool +get_boolean gv = withManagedPtr gv $ \ptr -> (/= 0) <$> _get_boolean ptr + +foreign import ccall unsafe "g_value_set_gtype" _set_gtype :: + Ptr GValue -> CGType -> IO () +foreign import ccall unsafe "g_value_get_gtype" _get_gtype :: + Ptr GValue -> IO CGType + +set_gtype :: GValue -> GType -> IO () +set_gtype gv (GType g) = withManagedPtr gv $ \ptr -> _set_gtype ptr g + +get_gtype :: GValue -> IO GType +get_gtype gv = GType <$> withManagedPtr gv _get_gtype + +foreign import ccall "g_value_set_object" _set_object :: + Ptr GValue -> Ptr a -> IO () +foreign import ccall "g_value_get_object" _get_object :: + Ptr GValue -> IO (Ptr a) + +set_object :: GObject a => GValue -> Ptr a -> IO () +set_object gv o = withManagedPtr gv $ flip _set_object o + +get_object :: GObject b => GValue -> IO (Ptr b) +get_object gv = withManagedPtr gv _get_object + +foreign import ccall "g_value_set_boxed" _set_boxed :: + Ptr GValue -> Ptr a -> IO () +foreign import ccall "g_value_get_boxed" _get_boxed :: + Ptr GValue -> IO (Ptr b) + +set_boxed :: GValue -> Ptr a -> IO () +set_boxed gv b = withManagedPtr gv $ flip _set_boxed b + +get_boxed :: GValue -> IO (Ptr b) +get_boxed gv = withManagedPtr gv _get_boxed + +foreign import ccall "g_value_set_variant" _set_variant :: + Ptr GValue -> Ptr GVariant -> IO () +foreign import ccall "g_value_get_variant" _get_variant :: + Ptr GValue -> IO (Ptr GVariant) + +set_variant :: GValue -> Ptr GVariant -> IO () +set_variant gv v = withManagedPtr gv $ flip _set_variant v + +get_variant :: GValue -> IO (Ptr GVariant) +get_variant gv = withManagedPtr gv _get_variant + +foreign import ccall unsafe "g_value_set_enum" _set_enum :: + Ptr GValue -> CUInt -> IO () +foreign import ccall unsafe "g_value_get_enum" _get_enum :: + Ptr GValue -> IO CUInt + +set_enum :: GValue -> CUInt -> IO () +set_enum gv e = withManagedPtr gv $ flip _set_enum e + +get_enum :: GValue -> IO CUInt +get_enum gv = withManagedPtr gv _get_enum + +foreign import ccall unsafe "g_value_set_flags" _set_flags :: + Ptr GValue -> CUInt -> IO () +foreign import ccall unsafe "g_value_get_flags" _get_flags :: + Ptr GValue -> IO CUInt + +set_flags :: GValue -> CUInt -> IO () +set_flags gv f = withManagedPtr gv $ flip _set_flags f + +get_flags :: GValue -> IO CUInt +get_flags gv = withManagedPtr gv _get_flags diff --git a/src/Data/GI/Base/GVariant.hsc b/src/Data/GI/Base/GVariant.hsc new file mode 100644 --- /dev/null +++ b/src/Data/GI/Base/GVariant.hsc @@ -0,0 +1,976 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE EmptyDataDecls #-} +{-| +This module contains some helper functions for dealing with GVariant +values. The simplest way of dealing with them is by using the +'IsGVariant' typeclass: + +> str <- fromGVariant variant :: IO (Maybe Text) + +assuming that the variant is expected to contain a +string in UTF8 encoding. The code becomes even shorter if the type +checker can determine the return type for you: + + +> readStringVariant :: GVariant -> IO Text +> readStringVariant variant = +> fromGVariant variant >>= \case +> Nothing -> error "Variant was not a string" +> Just str -> return str + +Alternatively, you can use manually the gvariantFrom* and +gvariantTo* family of functions. +-} +module Data.GI.Base.GVariant + ( IsGVariant(..) + , IsGVariantBasicType + + , noGVariant + + , gvariantGetTypeString + + -- * Type wrappers + -- | Some 'GVariant' types are isomorphic to Haskell types, but they + -- carry some extra information. For example, there is a tuple + -- singlet type, which is isomorphic to a single Haskell value + -- with the added bit of information that it is wrapped in a tuple + -- container. In order to use these values you can use the + -- following wrappers, which allow the 'IsGVariant' instance to + -- disambiguate the requested type properly. + + , GVariantSinglet(GVariantSinglet) + , GVariantDictEntry(GVariantDictEntry) + , GVariantHandle(GVariantHandle) + , GVariantObjectPath + , newGVariantObjectPath + , gvariantObjectPathToText + , GVariantSignature + , newGVariantSignature + , gvariantSignatureToText + + -- * Manual memory management + + , wrapGVariantPtr + , newGVariantFromPtr + , refGVariant + , unrefGVariant + + -- * Manual conversions + + -- ** Basic types + -- + -- | The use of these should be fairly self-explanatory. If you + -- want to convert a Haskell type into a 'GVariant', use + -- gvariantTo*. If you want to convert a 'GVariant' into a Haskell + -- type, use gvariantFrom*. The conversion can fail if the + -- 'GVariant' is not of the expected type (if you want to convert + -- a 'GVariant' containing a 'Int16' into a 'Text' value, say), in + -- which case 'Nothing' will be returned. + , gvariantToBool + , gvariantFromBool + + , gvariantToWord8 + , gvariantFromWord8 + + , gvariantToInt16 + , gvariantFromInt16 + + , gvariantToWord16 + , gvariantFromWord16 + + , gvariantToInt32 + , gvariantFromInt32 + + , gvariantToWord32 + , gvariantFromWord32 + + , gvariantToInt64 + , gvariantFromInt64 + + , gvariantToWord64 + , gvariantFromWord64 + + , gvariantToHandle + , gvariantFromHandle + + , gvariantToDouble + , gvariantFromDouble + + , gvariantToText + , gvariantFromText + + , gvariantToObjectPath + , gvariantFromObjectPath + + , gvariantToSignature + , gvariantFromSignature + + -- ** Container type conversions + , gvariantToGVariant + , gvariantFromGVariant + + , gvariantToBytestring + , gvariantFromBytestring + + , gvariantFromMaybe + , gvariantToMaybe + + , gvariantFromDictEntry + , gvariantToDictEntry + + , gvariantFromMap + , gvariantToMap + + , gvariantFromList + , gvariantToList + + , gvariantFromTuple + , gvariantToTuple + ) where + +#include + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative ((<$>), (<*>)) +#endif +import Control.Monad (when, void, (>=>)) +import Control.Exception.Base (bracket) + +import Data.Text (Text) +import Data.ByteString (ByteString) +import qualified Data.ByteString as B +import Data.Word +import Data.Int +import Data.Monoid ((<>)) +import Data.Maybe (isJust, fromJust) +import qualified Data.Map as M + +import System.IO.Unsafe (unsafePerformIO) +import Foreign.C +import Foreign.Ptr +import Foreign.ForeignPtr + +import Data.GI.Base.BasicTypes (GVariant(..)) +import Data.GI.Base.BasicConversions +import Data.GI.Base.ManagedPtr (withManagedPtr, withManagedPtrList) +import Data.GI.Base.Utils (freeMem) + +-- | An alias for @Nothing :: Maybe GVariant@ to save some typing. +noGVariant :: Maybe GVariant +noGVariant = Nothing + +-- | The typeclass for types that can be automatically marshalled into +-- 'GVariant' using 'toGVariant' and 'fromGVariant'. +class IsGVariant a where + -- | Convert a value of the given type into a GVariant. + toGVariant :: a -> IO GVariant + -- | Try to decode a 'GVariant' into a target type. If the + -- conversion fails we return 'Nothing'. The type that was + -- expected can be obtained by calling 'toGVariantFormatString', + -- and the actual type as understood by the 'GVariant' code can be + -- obtained by calling 'gvariantToTypeString'. + fromGVariant :: GVariant -> IO (Maybe a) + -- | The expected format string for this type (the argument is + -- ignored). + toGVariantFormatString :: a -> Text + +-- Same as fromGVariant, for cases where we have checked that things +-- have the right type in advance. +unsafeFromGVariant :: IsGVariant a => GVariant -> IO a +unsafeFromGVariant gv = + fromGVariant gv >>= \case + Nothing -> error "Error decoding GVariant. This is a bug in haskell-gi, please report it." + Just value -> return value + +-- | The typeclass for basic type 'GVariant' types, i.e. those that +-- are not containers. +class Ord a => IsGVariantBasicType a + +-- | Haskell has no notion of one element tuples, but GVariants do, so +-- the following allows for marshalling one element tuples properly +-- using 'fromGVariant' and 'toGVariant'. For instance, to construct a +-- single element tuple containing a string, you could do +-- +-- > toGVariant (GVariantSinglet "Test") +newtype GVariantSinglet a = GVariantSinglet a + deriving (Eq, Show) + +data GVariantType + +foreign import ccall "g_variant_type_new" g_variant_type_new :: + CString -> IO (Ptr GVariantType) + +foreign import ccall "g_variant_type_free" g_variant_type_free :: + Ptr GVariantType -> IO () + +foreign import ccall "g_variant_is_of_type" g_variant_is_of_type :: + Ptr GVariant -> Ptr GVariantType -> IO #{type gboolean} + +withGVariantType :: Text -> (Ptr GVariantType -> IO a) -> IO a +withGVariantType text action = withTextCString text $ \textPtr -> + bracket (g_variant_type_new textPtr) + g_variant_type_free + action + +gvariantIsOfType :: Text -> GVariant -> IO Bool +gvariantIsOfType typeString variant = + withGVariantType typeString $ + \typePtr -> + (toEnum . fromIntegral) <$> withManagedPtr variant + (\vptr -> g_variant_is_of_type + vptr typePtr) + +withExplicitType :: Text -> (Ptr GVariant -> IO a) -> GVariant -> IO (Maybe a) +withExplicitType format action variant = do + check <- gvariantIsOfType format variant + if check + then Just <$> withManagedPtr variant action + else return Nothing + +withTypeCheck :: forall a. (IsGVariant a) => + (Ptr GVariant -> IO a) -> GVariant -> IO (Maybe a) +withTypeCheck = withExplicitType $ toGVariantFormatString (undefined :: a) + +foreign import ccall "g_variant_get_type_string" g_variant_get_type_string + :: Ptr GVariant -> IO CString + +-- | Get the expected type of a 'GVariant', in 'GVariant' +-- notation. See +-- +-- for the meaning of the resulting format string. +gvariantGetTypeString :: GVariant -> IO Text +gvariantGetTypeString variant = + withManagedPtr variant (g_variant_get_type_string >=> cstringToText) + +foreign import ccall "g_variant_is_floating" g_variant_is_floating :: + Ptr GVariant -> IO CInt +foreign import ccall "g_variant_ref_sink" g_variant_ref_sink :: + Ptr GVariant -> IO (Ptr GVariant) +foreign import ccall "g_variant_ref" g_variant_ref :: + Ptr GVariant -> IO (Ptr GVariant) +foreign import ccall "g_variant_unref" g_variant_unref :: + Ptr GVariant -> IO () +foreign import ccall "&g_variant_unref" ptr_to_g_variant_unref :: + FunPtr (Ptr GVariant -> IO ()) + +-- | Take ownership of a passed in 'Ptr' (typically created just for +-- us, so if it is floating we sink it). +wrapGVariantPtr :: Ptr GVariant -> IO GVariant +wrapGVariantPtr ptr = do + floating <- g_variant_is_floating ptr + when (floating /= 0) $ void $ g_variant_ref_sink ptr + fPtr <- newForeignPtr ptr_to_g_variant_unref ptr + return $! GVariant fPtr + +-- | Construct a Haskell wrapper for the given 'GVariant', without +-- assuming ownership. +newGVariantFromPtr :: Ptr GVariant -> IO GVariant +newGVariantFromPtr ptr = do + fPtr <- g_variant_ref ptr >>= newForeignPtr ptr_to_g_variant_unref + return $! GVariant fPtr + +-- | Add a reference to the given 'GVariant'. +refGVariant :: GVariant -> IO (Ptr GVariant) +refGVariant (GVariant fptr) = withForeignPtr fptr g_variant_ref + +-- | Remove a reference to the given 'GVariant'. +unrefGVariant :: GVariant -> IO () +unrefGVariant (GVariant fptr) = withForeignPtr fptr g_variant_unref + +instance IsGVariant Bool where + toGVariant = gvariantFromBool + fromGVariant = gvariantToBool + toGVariantFormatString _ = "b" +instance IsGVariantBasicType Bool + +foreign import ccall "g_variant_new_boolean" new_bool + :: #{type gboolean} -> IO (Ptr GVariant) + +gvariantFromBool :: Bool -> IO GVariant +gvariantFromBool = (new_bool . fromIntegral . fromEnum) >=> wrapGVariantPtr + +foreign import ccall "g_variant_get_boolean" get_bool + :: Ptr GVariant -> IO #{type gboolean} + +gvariantToBool :: GVariant -> IO (Maybe Bool) +gvariantToBool = withTypeCheck $ get_bool >=> (return . toEnum . fromIntegral) + +instance IsGVariant Word8 where + toGVariant = gvariantFromWord8 + fromGVariant = gvariantToWord8 + toGVariantFormatString _ = "y" +instance IsGVariantBasicType Word8 + +foreign import ccall "g_variant_new_byte" new_byte + :: #{type guchar} -> IO (Ptr GVariant) + +gvariantFromWord8 :: Word8 -> IO GVariant +gvariantFromWord8 = (new_byte . fromIntegral) >=> wrapGVariantPtr + +foreign import ccall "g_variant_get_byte" get_byte + :: Ptr GVariant -> IO #{type guchar} + +gvariantToWord8 :: GVariant -> IO (Maybe Word8) +gvariantToWord8 = withTypeCheck $ get_byte >=> (return . fromIntegral) + +instance IsGVariant Int16 where + toGVariant = gvariantFromInt16 + fromGVariant = gvariantToInt16 + toGVariantFormatString _ = "n" +instance IsGVariantBasicType Int16 + +foreign import ccall "g_variant_new_int16" new_int16 + :: #{type gint16} -> IO (Ptr GVariant) + +gvariantFromInt16 :: Int16 -> IO GVariant +gvariantFromInt16 = (new_int16 . fromIntegral) >=> wrapGVariantPtr + +foreign import ccall "g_variant_get_int16" get_int16 + :: Ptr GVariant -> IO #{type gint16} + +gvariantToInt16 :: GVariant -> IO (Maybe Int16) +gvariantToInt16 = withTypeCheck $ get_int16 >=> (return . fromIntegral) + +instance IsGVariant Word16 where + toGVariant = gvariantFromWord16 + fromGVariant = gvariantToWord16 + toGVariantFormatString _ = "q" +instance IsGVariantBasicType Word16 + +foreign import ccall "g_variant_new_uint16" new_uint16 + :: #{type guint16} -> IO (Ptr GVariant) + +gvariantFromWord16 :: Word16 -> IO GVariant +gvariantFromWord16 = new_uint16 . fromIntegral >=> wrapGVariantPtr + +foreign import ccall "g_variant_get_uint16" get_uint16 + :: Ptr GVariant -> IO #{type guint16} + +gvariantToWord16 :: GVariant -> IO (Maybe Word16) +gvariantToWord16 = withTypeCheck $ get_uint16 >=> (return . fromIntegral) + +instance IsGVariant Int32 where + toGVariant = gvariantFromInt32 + fromGVariant = gvariantToInt32 + toGVariantFormatString _ = "i" +instance IsGVariantBasicType Int32 + +foreign import ccall "g_variant_new_int32" new_int32 + :: #{type gint16} -> IO (Ptr GVariant) + +gvariantFromInt32 :: Int32 -> IO GVariant +gvariantFromInt32 = (new_int32 . fromIntegral) >=> wrapGVariantPtr + +foreign import ccall "g_variant_get_int32" get_int32 + :: Ptr GVariant -> IO #{type gint32} + +gvariantToInt32 :: GVariant -> IO (Maybe Int32) +gvariantToInt32 = withTypeCheck $ get_int32 >=> (return . fromIntegral) + +instance IsGVariant Word32 where + toGVariant = gvariantFromWord32 + fromGVariant = gvariantToWord32 + toGVariantFormatString _ = "u" +instance IsGVariantBasicType Word32 + +foreign import ccall "g_variant_new_uint32" new_uint32 + :: #{type guint32} -> IO (Ptr GVariant) + +gvariantFromWord32 :: Word32 -> IO GVariant +gvariantFromWord32 = (new_uint32 . fromIntegral) >=> wrapGVariantPtr + +foreign import ccall "g_variant_get_uint32" get_uint32 + :: Ptr GVariant -> IO #{type guint32} + +gvariantToWord32 :: GVariant -> IO (Maybe Word32) +gvariantToWord32 = withTypeCheck $ get_uint32 >=> (return . fromIntegral) + +instance IsGVariant Int64 where + toGVariant = gvariantFromInt64 + fromGVariant = gvariantToInt64 + toGVariantFormatString _ = "x" +instance IsGVariantBasicType Int64 + +foreign import ccall "g_variant_new_int64" new_int64 + :: #{type gint64} -> IO (Ptr GVariant) + +gvariantFromInt64 :: Int64 -> IO GVariant +gvariantFromInt64 = (new_int64 . fromIntegral) >=> wrapGVariantPtr + +foreign import ccall "g_variant_get_int64" get_int64 + :: Ptr GVariant -> IO #{type gint64} + +gvariantToInt64 :: GVariant -> IO (Maybe Int64) +gvariantToInt64 = withTypeCheck $ get_int64 >=> (return . fromIntegral) + +instance IsGVariant Word64 where + toGVariant = gvariantFromWord64 + fromGVariant = gvariantToWord64 + toGVariantFormatString _ = "t" +instance IsGVariantBasicType Word64 + +foreign import ccall "g_variant_new_uint64" new_uint64 + :: #{type guint64} -> IO (Ptr GVariant) + +gvariantFromWord64 :: Word64 -> IO GVariant +gvariantFromWord64 = (new_uint64 . fromIntegral) >=> wrapGVariantPtr + +foreign import ccall "g_variant_get_uint64" get_uint64 + :: Ptr GVariant -> IO #{type guint64} + +gvariantToWord64 :: GVariant -> IO (Maybe Word64) +gvariantToWord64 = withTypeCheck $ get_uint64 >=> (return . fromIntegral) + +newtype GVariantHandle = GVariantHandle Int32 + deriving (Eq, Ord, Show) + +instance IsGVariant GVariantHandle where + toGVariant (GVariantHandle h) = gvariantFromHandle h + fromGVariant = gvariantToHandle >=> (return . (GVariantHandle <$>)) + toGVariantFormatString _ = "h" +instance IsGVariantBasicType GVariantHandle + +foreign import ccall "g_variant_new_handle" new_handle + :: #{type gint32} -> IO (Ptr GVariant) + +-- | Convert a DBus handle (an 'Int32') into a 'GVariant'. +gvariantFromHandle :: Int32 -> IO GVariant +gvariantFromHandle h = (new_handle . fromIntegral) h >>= wrapGVariantPtr + +foreign import ccall "g_variant_get_handle" get_handle + :: Ptr GVariant -> IO #{type gint32} + +-- | Extract the DBus handle (an 'Int32') inside a 'GVariant'. +gvariantToHandle :: GVariant -> IO (Maybe Int32) +gvariantToHandle = + withExplicitType (toGVariantFormatString (undefined :: GVariantHandle)) $ + get_handle >=> (return . fromIntegral) + +instance IsGVariant Double where + toGVariant = gvariantFromDouble + fromGVariant = gvariantToDouble + toGVariantFormatString _ = "d" +instance IsGVariantBasicType Double + +foreign import ccall "g_variant_new_double" new_double + :: #{type gdouble} -> IO (Ptr GVariant) + +gvariantFromDouble :: Double -> IO GVariant +gvariantFromDouble = (new_double . realToFrac) >=> wrapGVariantPtr + +foreign import ccall "g_variant_get_double" get_double + :: Ptr GVariant -> IO #{type gdouble} + +gvariantToDouble :: GVariant -> IO (Maybe Double) +gvariantToDouble = withTypeCheck $ get_double >=> (return . realToFrac) + +instance IsGVariant Text where + toGVariant = gvariantFromText + fromGVariant = gvariantToText + toGVariantFormatString _ = "s" +instance IsGVariantBasicType Text + +foreign import ccall "g_variant_get_string" _get_string + :: Ptr GVariant -> Ptr #{type gsize} -> IO CString + +get_string :: Ptr GVariant -> IO CString +get_string v = _get_string v nullPtr + +-- | Decode an UTF-8 encoded string 'GVariant' into 'Text'. +gvariantToText :: GVariant -> IO (Maybe Text) +gvariantToText = withTypeCheck $ get_string >=> cstringToText + +foreign import ccall "g_variant_new_take_string" take_string + :: CString -> IO (Ptr GVariant) + +-- | Encode a 'Text' into an UTF-8 encoded string 'GVariant'. +gvariantFromText :: Text -> IO GVariant +gvariantFromText = textToCString >=> take_string >=> wrapGVariantPtr + +foreign import ccall "g_variant_is_object_path" g_variant_is_object_path :: + CString -> IO #{type gboolean} + +-- | An object representing a DBus object path, which is a particular +-- type of 'GVariant' too. (Just a string with some specific +-- requirements.) In order to construct/deconstruct a +-- 'GVariantObjectPath' one can use 'newGVariantObjectPath' +-- and 'gvariantObjectPathToText'. +newtype GVariantObjectPath = GVariantObjectPath Text + deriving (Ord, Eq, Show) + +-- | Try to construct a DBus object path. If the passed string is not +-- a valid object path 'Nothing' will be returned. +newGVariantObjectPath :: Text -> Maybe GVariantObjectPath +newGVariantObjectPath p = unsafePerformIO $ + withTextCString p $ \cstr -> do + isObjectPath <- toEnum . fromIntegral <$> g_variant_is_object_path cstr + if isObjectPath + then return $ Just (GVariantObjectPath p) + else return Nothing + +-- | Return the 'Text' representation of a 'GVariantObjectPath'. +gvariantObjectPathToText :: GVariantObjectPath -> Text +gvariantObjectPathToText (GVariantObjectPath p) = p + +instance IsGVariant GVariantObjectPath where + toGVariant = gvariantFromObjectPath + fromGVariant = gvariantToObjectPath >=> return . (GVariantObjectPath <$>) + toGVariantFormatString _ = "o" +instance IsGVariantBasicType GVariantObjectPath + +foreign import ccall "g_variant_new_object_path" new_object_path + :: CString -> IO (Ptr GVariant) + +-- | Construct a 'GVariant' containing an object path. In order to +-- build a 'GVariantObjectPath' value see 'newGVariantObjectPath'. +gvariantFromObjectPath :: GVariantObjectPath -> IO GVariant +gvariantFromObjectPath (GVariantObjectPath p) = + withTextCString p $ new_object_path >=> wrapGVariantPtr + +-- | Extract a 'GVariantObjectPath' from a 'GVariant', represented as +-- its underlying 'Text' representation. +gvariantToObjectPath :: GVariant -> IO (Maybe Text) +gvariantToObjectPath = + withExplicitType (toGVariantFormatString (undefined :: GVariantObjectPath)) + (get_string >=> cstringToText) + +foreign import ccall "g_variant_is_signature" g_variant_is_signature :: + CString -> IO #{type gboolean} + +-- | An object representing a DBus signature, which is a particular +-- type of 'GVariant' too. (Just a string with some specific +-- requirements.) In order to construct/deconstruct a +-- 'GVariantSignature' one can use 'newGVariantSignature' and +-- 'gvariantSignatureToText'. +newtype GVariantSignature = GVariantSignature Text + deriving (Ord, Eq, Show) + +-- | Try to construct a DBus object path. If the passed string is not +-- a valid DBus signature 'Nothing' will be returned. +newGVariantSignature :: Text -> Maybe GVariantSignature +newGVariantSignature p = unsafePerformIO $ + withTextCString p $ \cstr -> do + isSignature <- toEnum . fromIntegral <$> g_variant_is_signature cstr + if isSignature + then return $ Just (GVariantSignature p) + else return Nothing + +-- | Return the 'Text' representation of a 'GVariantSignature'. +gvariantSignatureToText :: GVariantSignature -> Text +gvariantSignatureToText (GVariantSignature p) = p + +instance IsGVariant GVariantSignature where + toGVariant = gvariantFromSignature + fromGVariant = gvariantToSignature >=> return . (GVariantSignature <$>) + toGVariantFormatString _ = "g" +instance IsGVariantBasicType GVariantSignature + +foreign import ccall "g_variant_new_signature" new_signature + :: CString -> IO (Ptr GVariant) + +-- | Construct a 'GVariant' containing an DBus signature. In order to +-- build a 'GVariantSignature' value see 'newGVariantSignature'. +gvariantFromSignature :: GVariantSignature -> IO GVariant +gvariantFromSignature (GVariantSignature p) = + withTextCString p $ new_signature >=> wrapGVariantPtr + +-- | Extract a 'GVariantSignature' from a 'GVariant', represented as +-- 'Text'. +gvariantToSignature :: GVariant -> IO (Maybe Text) +gvariantToSignature = + withExplicitType (toGVariantFormatString (undefined :: GVariantSignature)) + $ get_string >=> cstringToText + +instance IsGVariant GVariant where + toGVariant = gvariantFromGVariant + fromGVariant = gvariantToGVariant + toGVariantFormatString _ = "v" + +foreign import ccall "g_variant_new_variant" new_variant + :: Ptr GVariant -> IO (Ptr GVariant) + +-- | Box a 'GVariant' inside another 'GVariant'. +gvariantFromGVariant :: GVariant -> IO GVariant +gvariantFromGVariant v = withManagedPtr v $ new_variant >=> wrapGVariantPtr + +foreign import ccall "g_variant_get_variant" get_variant + :: Ptr GVariant -> IO (Ptr GVariant) + +-- | Unbox a 'GVariant' contained inside another 'GVariant'. +gvariantToGVariant :: GVariant -> IO (Maybe GVariant) +gvariantToGVariant = withTypeCheck $ get_variant >=> wrapGVariantPtr + +instance IsGVariant ByteString where + toGVariant = gvariantFromBytestring + fromGVariant = gvariantToBytestring + toGVariantFormatString _ = "ay" + +foreign import ccall "g_variant_get_bytestring" get_bytestring + :: Ptr GVariant -> IO CString + +-- | Extract a zero terminated list of bytes into a 'ByteString'. +gvariantToBytestring :: GVariant -> IO (Maybe ByteString) +gvariantToBytestring = withTypeCheck (get_bytestring >=> cstringToByteString) + +foreign import ccall "g_variant_new_bytestring" new_bytestring + :: CString -> IO (Ptr GVariant) + +-- | Encode a 'ByteString' into a list of bytes 'GVariant'. +gvariantFromBytestring :: ByteString -> IO GVariant +gvariantFromBytestring bs = wrapGVariantPtr =<< + B.useAsCString bs new_bytestring + + +foreign import ccall "g_variant_n_children" g_variant_n_children + :: Ptr GVariant -> IO #{type gsize} + +foreign import ccall "g_variant_get_child_value" g_variant_get_child_value + :: Ptr GVariant -> #{type gsize} -> IO (Ptr GVariant) + +-- No type checking is done here, it is assumed that the caller knows +-- that the passed variant is indeed of a container type. +gvariant_get_children :: (Ptr GVariant) -> IO [GVariant] +gvariant_get_children vptr = do + n_children <- g_variant_n_children vptr + mapM ((g_variant_get_child_value vptr) >=> wrapGVariantPtr) + [0..(n_children-1)] + +instance IsGVariant a => IsGVariant (Maybe a) where + toGVariant = gvariantFromMaybe + fromGVariant = gvariantToMaybe + toGVariantFormatString _ = "m" <> toGVariantFormatString (undefined :: a) + +foreign import ccall "g_variant_new_maybe" g_variant_new_maybe :: + Ptr GVariantType -> Ptr GVariant -> IO (Ptr GVariant) + +-- | Convert a 'Maybe' value into a corresponding 'GVariant' of maybe +-- type. +gvariantFromMaybe :: forall a. IsGVariant a => Maybe a -> IO GVariant +gvariantFromMaybe m = do + let fmt = toGVariantFormatString (undefined :: a) + withGVariantType fmt $ \tPtr -> + case m of + Just child -> do + childVariant <- toGVariant child + withManagedPtr childVariant + (g_variant_new_maybe tPtr >=> wrapGVariantPtr) + Nothing -> g_variant_new_maybe tPtr nullPtr >>= wrapGVariantPtr + +-- | Try to decode a maybe 'GVariant' into the corresponding 'Maybe' +-- type. If the conversion is successful this returns @Just x@, where +-- @x@ itself is of 'Maybe' type. So, in particular, @Just Nothing@ +-- indicates a successful call, and means that the GVariant of maybe +-- type was empty. +gvariantToMaybe :: forall a. IsGVariant a => GVariant -> IO (Maybe (Maybe a)) +gvariantToMaybe v = do + let fmt = toGVariantFormatString (undefined :: Maybe a) + withExplicitType fmt gvariant_get_children v >>= + \case + Just [] -> return (Just Nothing) + Just [child] -> fromGVariant child >>= + \case + Nothing -> return Nothing + Just result -> return (Just (Just result)) + Just _ -> error "gvariantToMaybe :: the impossible happened, this is a bug." + Nothing -> return Nothing + +-- | A DictEntry 'GVariant' is isomorphic to a two-tuple. Wrapping the +-- values into a 'GVariantDictentry' allows the 'IsGVariant' instance +-- to do the right thing. +data GVariantDictEntry key value = GVariantDictEntry key value + deriving (Eq, Show) + +instance (IsGVariant a, IsGVariantBasicType a, IsGVariant b) => + IsGVariant (GVariantDictEntry a b) where + toGVariant (GVariantDictEntry key value) = + gvariantFromDictEntry key value + fromGVariant gv = + ((uncurry GVariantDictEntry) <$>) <$> gvariantToDictEntry gv + toGVariantFormatString _ = "{" + <> toGVariantFormatString (undefined :: a) + <> toGVariantFormatString (undefined :: b) + <> "}" + +foreign import ccall "g_variant_new_dict_entry" g_variant_new_dict_entry :: + Ptr GVariant -> Ptr GVariant -> IO (Ptr GVariant) + +-- | Construct a 'GVariant' of type DictEntry from the given 'key' and +-- 'value'. The key must be a basic 'GVariant' type, i.e. not a +-- container. This is determined by whether it belongs to the +-- 'IsGVariantBasicType' typeclass. On the other hand 'value' is an +-- arbitrary 'GVariant', and in particular it can be a container type. +gvariantFromDictEntry :: (IsGVariant key, IsGVariantBasicType key, + IsGVariant value) => + key -> value -> IO GVariant +gvariantFromDictEntry key value = do + keyVar <- toGVariant key + valueVar <- toGVariant value + withManagedPtr keyVar $ \keyPtr -> + withManagedPtr valueVar $ \valuePtr -> + g_variant_new_dict_entry keyPtr valuePtr >>= wrapGVariantPtr + +-- | Unpack a DictEntry variant into 'key' and 'value', which are +-- returned as a two element tuple in case of success. +gvariantToDictEntry :: forall key value. + (IsGVariant key, IsGVariantBasicType key, + IsGVariant value) => + GVariant -> IO (Maybe (key, value)) +gvariantToDictEntry = + withExplicitType fmt $ \varPtr -> do + [key, value] <- gvariant_get_children varPtr + (,) <$> unsafeFromGVariant key <*> unsafeFromGVariant value + where + fmt = toGVariantFormatString (undefined :: GVariantDictEntry key value) + +instance (IsGVariant a, IsGVariantBasicType a, IsGVariant b) => + IsGVariant (M.Map a b) where + toGVariant = gvariantFromMap + fromGVariant = gvariantToMap + toGVariantFormatString _ = "a{" + <> toGVariantFormatString (undefined :: a) + <> toGVariantFormatString (undefined :: b) + <> "}" + +-- | Pack a 'Map' into a 'GVariant' for dictionary type, which is just +-- an array of 'GVariantDictEntry'. +gvariantFromMap :: (IsGVariant key, IsGVariantBasicType key, + IsGVariant value) => + M.Map key value -> IO GVariant +gvariantFromMap m = gvariantFromList $ + map (uncurry GVariantDictEntry) (M.toList m) + +-- | Unpack a 'GVariant' into a 'M.Map'. Notice that this assumes that +-- all the elements in the 'GVariant' array of 'GVariantDictEntry' are +-- of the same type, which is not necessary for a generic 'GVariant', +-- so this is somewhat restrictive. For the general case it is +-- necessary to use 'gvariantToList' plus 'gvariantToDictEntry' +-- directly. +gvariantToMap :: forall key value. + (IsGVariant key, IsGVariantBasicType key, + IsGVariant value) => + GVariant -> IO (Maybe (M.Map key value)) +gvariantToMap = gvariantToList >=> (return . (fromDictEntryList <$>)) + where fromDictEntryList :: [GVariantDictEntry key value] -> + M.Map key value + fromDictEntryList = M.fromList . (map tuplefy) + tuplefy :: GVariantDictEntry key value -> (key, value) + tuplefy (GVariantDictEntry key value) = (key, value) + +instance IsGVariant a => IsGVariant [a] where + toGVariant = gvariantFromList + fromGVariant = gvariantToList + toGVariantFormatString _ = "a" <> toGVariantFormatString (undefined :: a) + +foreign import ccall "g_variant_new_array" g_variant_new_array :: + Ptr GVariantType -> Ptr (Ptr GVariant) -> #{type gsize} -> IO (Ptr GVariant) + +-- | Given a list of elements construct a 'GVariant' array containing +-- them. +gvariantFromList :: forall a. IsGVariant a => [a] -> IO GVariant +gvariantFromList children = do + let fmt = toGVariantFormatString (undefined :: a) + mapM toGVariant children >>= \childVariants -> + withManagedPtrList childVariants $ \childrenPtrs -> do + withGVariantType fmt $ \childType -> do + packed <- packPtrArray childrenPtrs + result <- g_variant_new_array childType packed + (fromIntegral $ length children) + freeMem packed + wrapGVariantPtr result + +-- | Unpack a 'GVariant' array into its elements. +gvariantToList :: forall a. IsGVariant a => GVariant -> IO (Maybe [a]) +gvariantToList = withExplicitType (toGVariantFormatString (undefined :: [a])) + (gvariant_get_children >=> mapM unsafeFromGVariant) + +foreign import ccall "g_variant_new_tuple" g_variant_new_tuple + :: Ptr (Ptr GVariant) -> #{type gsize} -> IO (Ptr GVariant) + +-- | Given a list of 'GVariant', construct a 'GVariant' tuple +-- containing the elements in the list. +gvariantFromTuple :: [GVariant] -> IO GVariant +gvariantFromTuple children = + withManagedPtrList children $ \childrenPtrs -> do + packed <- packPtrArray childrenPtrs + result <- g_variant_new_tuple packed (fromIntegral $ length children) + freeMem packed + wrapGVariantPtr result + +-- | Extract the children of a 'GVariant' tuple into a list. +gvariantToTuple :: GVariant -> IO (Maybe [GVariant]) +gvariantToTuple = withExplicitType "r" gvariant_get_children + +-- | The empty tuple GVariant, mostly useful for type checking. +instance IsGVariant () where + toGVariant _ = gvariantFromTuple [] + fromGVariant = withTypeCheck (const $ return ()) + toGVariantFormatString _ = "()" + +-- | One element tuples. +instance IsGVariant a => IsGVariant (GVariantSinglet a) where + toGVariant (GVariantSinglet s) = gvariantFromSinglet s + fromGVariant = gvariantToSinglet >=> return . (GVariantSinglet <$>) + toGVariantFormatString _ = "(" + <> toGVariantFormatString (undefined :: a) + <> ")" + +gvariantFromSinglet :: IsGVariant a => a -> IO GVariant +gvariantFromSinglet s = do + sv <- toGVariant s + gvariantFromTuple [sv] + +gvariantToSinglet :: forall a. IsGVariant a => GVariant -> IO (Maybe a) +gvariantToSinglet = withExplicitType fmt + (gvariant_get_children + >=> return . head + >=> unsafeFromGVariant) + where fmt = toGVariantFormatString (undefined :: GVariantSinglet a) + +instance (IsGVariant a, IsGVariant b) => IsGVariant (a,b) where + toGVariant = gvariantFromTwoTuple + fromGVariant = gvariantToTwoTuple + toGVariantFormatString _ = "(" + <> toGVariantFormatString (undefined :: a) + <> toGVariantFormatString (undefined :: b) + <> ")" + +gvariantFromTwoTuple :: (IsGVariant a, IsGVariant b) => + (a,b) -> IO GVariant +gvariantFromTwoTuple (a, b) = do + va <- toGVariant a + vb <- toGVariant b + gvariantFromTuple [va, vb] + +gvariantToTwoTuple :: forall a b. (IsGVariant a, IsGVariant b) => + GVariant -> IO (Maybe (a,b)) +gvariantToTwoTuple variant = do + let expectedType = toGVariantFormatString (undefined :: (a,b)) + maybeChildren <- withExplicitType expectedType gvariant_get_children variant + if isJust maybeChildren + then do + let (Just [a1,a2]) = maybeChildren + (ma1, ma2) <- (,) <$> fromGVariant a1 <*> fromGVariant a2 + return $ if isJust ma1 && isJust ma2 + then Just (fromJust ma1, fromJust ma2) + else Nothing + else return Nothing + +instance (IsGVariant a, IsGVariant b, IsGVariant c) => IsGVariant (a,b,c) where + toGVariant = gvariantFromThreeTuple + fromGVariant = gvariantToThreeTuple + toGVariantFormatString _ = "(" + <> toGVariantFormatString (undefined :: a) + <> toGVariantFormatString (undefined :: b) + <> toGVariantFormatString (undefined :: c) + <> ")" + +gvariantFromThreeTuple :: (IsGVariant a, IsGVariant b, IsGVariant c) => + (a,b,c) -> IO GVariant +gvariantFromThreeTuple (a, b, c) = do + va <- toGVariant a + vb <- toGVariant b + vc <- toGVariant c + gvariantFromTuple [va, vb, vc] + +gvariantToThreeTuple :: forall a b c. (IsGVariant a, IsGVariant b, + IsGVariant c) => + GVariant -> IO (Maybe (a,b,c)) +gvariantToThreeTuple variant = do + let expectedType = toGVariantFormatString (undefined :: (a,b,c)) + maybeChildren <- withExplicitType expectedType gvariant_get_children variant + if isJust maybeChildren + then do + let (Just [a1,a2,a3]) = maybeChildren + (ma1, ma2, ma3) <- (,,) <$> fromGVariant a1 + <*> fromGVariant a2 + <*> fromGVariant a3 + return $ if isJust ma1 && isJust ma2 && isJust ma3 + then Just (fromJust ma1, fromJust ma2, fromJust ma3) + else Nothing + else return Nothing + +instance (IsGVariant a, IsGVariant b, IsGVariant c, IsGVariant d) => + IsGVariant (a,b,c,d) where + toGVariant = gvariantFromFourTuple + fromGVariant = gvariantToFourTuple + toGVariantFormatString _ = "(" + <> toGVariantFormatString (undefined :: a) + <> toGVariantFormatString (undefined :: b) + <> toGVariantFormatString (undefined :: c) + <> toGVariantFormatString (undefined :: d) + <> ")" + +gvariantFromFourTuple :: (IsGVariant a, IsGVariant b, IsGVariant c, + IsGVariant d) => (a,b,c,d) -> IO GVariant +gvariantFromFourTuple (a, b, c, d) = do + va <- toGVariant a + vb <- toGVariant b + vc <- toGVariant c + vd <- toGVariant d + gvariantFromTuple [va, vb, vc, vd] + +gvariantToFourTuple :: forall a b c d. (IsGVariant a, IsGVariant b, + IsGVariant c, IsGVariant d) => + GVariant -> IO (Maybe (a,b,c,d)) +gvariantToFourTuple variant = do + let expectedType = toGVariantFormatString (undefined :: (a,b,c,d)) + maybeChildren <- withExplicitType expectedType gvariant_get_children variant + if isJust maybeChildren + then do + let (Just [a1,a2,a3,a4]) = maybeChildren + (ma1, ma2, ma3,ma4) <- (,,,) <$> fromGVariant a1 + <*> fromGVariant a2 + <*> fromGVariant a3 + <*> fromGVariant a4 + return $ if isJust ma1 && isJust ma2 && isJust ma3 && isJust ma4 + then Just (fromJust ma1, fromJust ma2, fromJust ma3, fromJust ma4) + else Nothing + else return Nothing + +instance (IsGVariant a, IsGVariant b, IsGVariant c, IsGVariant d, IsGVariant e) + => IsGVariant (a,b,c,d,e) where + toGVariant = gvariantFromFiveTuple + fromGVariant = gvariantToFiveTuple + toGVariantFormatString _ = "(" + <> toGVariantFormatString (undefined :: a) + <> toGVariantFormatString (undefined :: b) + <> toGVariantFormatString (undefined :: c) + <> toGVariantFormatString (undefined :: d) + <> toGVariantFormatString (undefined :: e) + <> ")" + +gvariantFromFiveTuple :: (IsGVariant a, IsGVariant b, IsGVariant c, + IsGVariant d, IsGVariant e) => + (a,b,c,d,e) -> IO GVariant +gvariantFromFiveTuple (a, b, c, d, e) = do + va <- toGVariant a + vb <- toGVariant b + vc <- toGVariant c + vd <- toGVariant d + ve <- toGVariant e + gvariantFromTuple [va, vb, vc, vd, ve] + +gvariantToFiveTuple :: forall a b c d e. + (IsGVariant a, IsGVariant b, IsGVariant c, + IsGVariant d, IsGVariant e) => + GVariant -> IO (Maybe (a,b,c,d,e)) +gvariantToFiveTuple variant = do + let expectedType = toGVariantFormatString (undefined :: (a,b,c,d,e)) + maybeChildren <- withExplicitType expectedType gvariant_get_children variant + if isJust maybeChildren + then do + let (Just [a1,a2,a3,a4,a5]) = maybeChildren + (ma1, ma2, ma3, ma4, ma5) <- (,,,,) <$> fromGVariant a1 + <*> fromGVariant a2 + <*> fromGVariant a3 + <*> fromGVariant a4 + <*> fromGVariant a5 + return $ if isJust ma1 && isJust ma2 && isJust ma3 && + isJust ma4 && isJust ma5 + then Just (fromJust ma1, fromJust ma2, fromJust ma3, + fromJust ma4, fromJust ma5) + else Nothing + else return Nothing diff --git a/src/Data/GI/Base/ManagedPtr.hs b/src/Data/GI/Base/ManagedPtr.hs new file mode 100644 --- /dev/null +++ b/src/Data/GI/Base/ManagedPtr.hs @@ -0,0 +1,245 @@ +{-# LANGUAGE FlexibleContexts, ScopedTypeVariables #-} +-- | We wrap most objects in a "managed pointer", which is simply a +-- newtype for a 'ForeignPtr' of the appropriate type: +-- +-- > newtype Foo = Foo (ForeignPtr Foo) +-- +-- Notice that types of this form are instances of +-- 'ForeignPtrNewtype'. The newtype is useful in order to make the +-- newtype an instance of different typeclasses. The routines in this +-- module deal with the memory management of such managed pointers. + +module Data.GI.Base.ManagedPtr + ( -- * Managed pointers + withManagedPtr + , withManagedPtrList + , unsafeManagedPtrGetPtr + , unsafeManagedPtrCastPtr + , touchManagedPtr + + -- * Safe casting + , castTo + , unsafeCastTo + + -- * Wrappers + , newObject + , wrapObject + , refObject + , unrefObject + , newBoxed + , wrapBoxed + , copyBoxed + , copyBoxedPtr + , freeBoxed + , wrapPtr + , newPtr + ) where + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative ((<$>)) +#endif +import Control.Monad (when, void) + +import Data.Coerce (coerce) + +import Foreign (finalizerFree, poke) +import Foreign.C (CInt(..)) +import Foreign.Ptr (Ptr, FunPtr, castPtr) +import Foreign.ForeignPtr (ForeignPtr, newForeignPtr, newForeignPtrEnv, touchForeignPtr) +import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr) + +import Data.GI.Base.BasicTypes +import Data.GI.Base.Utils + +-- | Perform an IO action on the 'Ptr' inside a managed pointer. +withManagedPtr :: ForeignPtrNewtype a => a -> (Ptr a -> IO c) -> IO c +withManagedPtr managed action = do + let ptr = unsafeManagedPtrGetPtr managed + result <- action ptr + touchManagedPtr managed + return result + +-- | Perform an IO action taking a list of 'Ptr' on a list of managed +-- pointers. +withManagedPtrList :: ForeignPtrNewtype a => [a] -> ([Ptr a] -> IO c) -> IO c +withManagedPtrList managedList action = do + let ptrs = map unsafeManagedPtrGetPtr managedList + result <- action ptrs + mapM_ touchManagedPtr managedList + return result + +-- | Return the 'Ptr' in a given managed pointer. As the name says, +-- this is potentially unsafe: the given 'Ptr' may only be used +-- /before/ a call to 'touchManagedPtr'. This function is of most +-- interest to the autogenerated bindings, for hand-written code +-- 'withManagedPtr' is almost always a better choice. +unsafeManagedPtrGetPtr :: ForeignPtrNewtype a => a -> Ptr a +unsafeManagedPtrGetPtr = unsafeManagedPtrCastPtr + +-- | Same as 'unsafeManagedPtrGetPtr', but is polymorphic on the +-- return type. +unsafeManagedPtrCastPtr :: forall a b. ForeignPtrNewtype a => a -> Ptr b +unsafeManagedPtrCastPtr x = let p = coerce x :: ForeignPtr () + in castPtr (unsafeForeignPtrToPtr p) + +-- | Ensure that the 'Ptr' in the given managed pointer is still alive +-- (i.e. it has not been garbage collected by the runtime) at the +-- point that this is called. +touchManagedPtr :: forall a. ForeignPtrNewtype a => a -> IO () +touchManagedPtr x = let p = coerce x :: ForeignPtr () + in touchForeignPtr p + +-- Safe casting machinery +foreign import ccall unsafe "check_object_type" + c_check_object_type :: Ptr o -> CGType -> CInt + +-- | Cast to the given type, checking that the cast is valid. If it is +-- not, we return `Nothing`. Usage: +-- +-- > maybeWidget <- castTo Widget label +castTo :: forall o o'. (GObject o, GObject o') => + (ForeignPtr o' -> o') -> o -> IO (Maybe o') +castTo constructor obj = + withManagedPtr obj $ \objPtr -> do + GType t <- gobjectType (undefined :: o') + if c_check_object_type objPtr t /= 1 + then return Nothing + else Just <$> newObject constructor objPtr + +-- | Cast to the given type, assuming that the cast will succeed. This +-- function will call `error` if the cast is illegal. +unsafeCastTo :: forall o o'. (GObject o, GObject o') => + (ForeignPtr o' -> o') -> o -> IO o' +unsafeCastTo constructor obj = + withManagedPtr obj $ \objPtr -> do + GType t <- gobjectType (undefined :: o') + if c_check_object_type objPtr t /= 1 + then do + srcType <- gobjectType obj >>= gtypeName + destType <- gobjectType (undefined :: o') >>= gtypeName + error $ "unsafeCastTo :: invalid conversion from " ++ srcType ++ " to " + ++ destType ++ " requested." + else newObject constructor objPtr + +-- Reference counting for constructors +foreign import ccall "&dbg_g_object_unref" + ptr_to_g_object_unref :: FunPtr (Ptr a -> IO ()) + +foreign import ccall "g_object_ref" g_object_ref :: + Ptr a -> IO (Ptr a) + +-- | Construct a Haskell wrapper for a 'GObject', increasing its +-- reference count. +newObject :: (GObject a, GObject b) => (ForeignPtr a -> a) -> Ptr b -> IO a +newObject constructor ptr = do + void $ g_object_ref ptr + fPtr <- newForeignPtr ptr_to_g_object_unref $ castPtr ptr + return $! constructor fPtr + +foreign import ccall "g_object_ref_sink" g_object_ref_sink :: + Ptr a -> IO (Ptr a) + +-- | Same as 'newObject', but we take ownership of the object. Newly +-- created 'GObject's are typically floating, so we use +-- . + +-- Notice that the +-- semantics here are a little bit subtle: some objects (such as +-- GtkWindow, see the code about "user_ref_count" in gtkwindow.c in +-- the gtk+ distribution) are created /without/ the floating flag, +-- since they own a reference to themselves. So, wrapping them is +-- really about adding a ref. If we add the ref, when Haskell drops +-- the last ref to the 'GObject' it will /g_object_unref/, and the +-- window will /g_object_unref/ itself upon destruction, so by the end +-- we don't leak memory. If we don't add the ref, there will be two +-- /g_object_unrefs/ acting on the object (one from Haskell and one from +-- the GtkWindow destroy) when the object is destroyed and the second +-- one will give a segfault. +-- +-- This is the story for GInitiallyUnowned objects (e.g. anything that +-- is a descendant from GtkWidget). For objects that are not initially +-- floating (i.e. not descendents of GInitiallyUnowned) we simply take +-- control of the reference. +wrapObject :: forall a b. (GObject a, GObject b) => + (ForeignPtr a -> a) -> Ptr b -> IO a +wrapObject constructor ptr = do + when (gobjectIsInitiallyUnowned (undefined :: a)) $ + void $ g_object_ref_sink ptr + fPtr <- newForeignPtr ptr_to_g_object_unref $ castPtr ptr + return $! constructor fPtr + +-- | Increase the reference count of the given 'GObject'. +refObject :: (GObject a, GObject b) => a -> IO (Ptr b) +refObject obj = castPtr <$> withManagedPtr obj g_object_ref + +foreign import ccall "g_object_unref" g_object_unref :: + Ptr a -> IO () + +-- | Decrease the reference count of the given 'GObject'. The memory +-- associated with the object may be released if the reference count +-- reaches 0. +unrefObject :: GObject a => a -> IO () +unrefObject obj = withManagedPtr obj g_object_unref + +foreign import ccall "& boxed_free_helper" boxed_free_helper :: + FunPtr (Ptr env -> Ptr a -> IO ()) + +foreign import ccall "g_boxed_copy" g_boxed_copy :: + CGType -> Ptr a -> IO (Ptr a) + +-- | Construct a Haskell wrapper for the given boxed object. We make a +-- copy of the object. +newBoxed :: forall a. BoxedObject a => (ForeignPtr a -> a) -> Ptr a -> IO a +newBoxed constructor ptr = do + GType gtype <- boxedType (undefined :: a) + env <- allocMem :: IO (Ptr CGType) -- Will be freed by boxed_free_helper + poke env gtype + ptr' <- g_boxed_copy gtype ptr + fPtr <- newForeignPtrEnv boxed_free_helper env ptr' + return $! constructor fPtr + +-- | Like 'newBoxed', but we do not make a copy (we "steal" the passed +-- object, so now it is managed by the Haskell runtime). +wrapBoxed :: forall a. BoxedObject a => (ForeignPtr a -> a) -> Ptr a -> IO a +wrapBoxed constructor ptr = do + GType gtype <- boxedType (undefined :: a) + env <- allocMem :: IO (Ptr CGType) -- Will be freed by boxed_free_helper + poke env gtype + fPtr <- newForeignPtrEnv boxed_free_helper env ptr + return $! constructor fPtr + +-- | Make a copy of the given boxed object. +copyBoxed :: forall a. BoxedObject a => a -> IO (Ptr a) +copyBoxed boxed = withManagedPtr boxed copyBoxedPtr + +-- | Like 'copyBoxed', but acting directly on a pointer, instead of a +-- managed pointer. +copyBoxedPtr :: forall a. BoxedObject a => Ptr a -> IO (Ptr a) +copyBoxedPtr ptr = do + GType gtype <- boxedType (undefined :: a) + g_boxed_copy gtype ptr + +foreign import ccall "g_boxed_free" g_boxed_free :: + CGType -> Ptr a -> IO () + +-- | Free the memory associated with a boxed object +freeBoxed :: forall a. BoxedObject a => a -> IO () +freeBoxed boxed = do + GType gtype <- boxedType (undefined :: a) + let ptr = unsafeManagedPtrGetPtr boxed + g_boxed_free gtype ptr + touchManagedPtr boxed + +-- | Wrap a pointer, taking ownership of it. +wrapPtr :: (ForeignPtr a -> a) -> Ptr a -> IO a +wrapPtr constructor ptr = do + fPtr <- newForeignPtr finalizerFree ptr + return $! constructor fPtr + +-- | Wrap a pointer to n bytes, making a copy of the data. +newPtr :: Int -> (ForeignPtr a -> a) -> Ptr a -> IO a +newPtr n constructor ptr = do + ptr' <- callocBytes n :: IO (Ptr a) + memcpy ptr' ptr n + fPtr <- newForeignPtr finalizerFree ptr' + return $! constructor fPtr diff --git a/src/Data/GI/Base/Overloading.hs b/src/Data/GI/Base/Overloading.hs new file mode 100644 --- /dev/null +++ b/src/Data/GI/Base/Overloading.hs @@ -0,0 +1,128 @@ +{-# LANGUAGE TypeOperators, KindSignatures, DataKinds, PolyKinds, + TypeFamilies, UndecidableInstances, EmptyDataDecls, + MultiParamTypeClasses, FlexibleInstances, ConstraintKinds #-} + +-- | Helpers for dealing with `GObject`s. + +module Data.GI.Base.Overloading + ( -- * Type level inheritance + ParentTypes + , IsDescendantOf + + -- * Looking up attributes in parent types + , AttributeList + , ResolveAttribute + , HasAttribute + , HasAttr + + -- * Looking up signals in parent types + , SignalList + , ResolveSignal + , HasSignal + ) where + +import GHC.Exts (Constraint) +import GHC.TypeLits + +-- | Join two lists. +type family JoinLists (as :: [a]) (bs :: [a]) :: [a] where + JoinLists '[] bs = bs + JoinLists (a ': as) bs = a ': JoinLists as bs + +-- | Look in the given list of (symbol, tag) tuples for the tag +-- corresponding to the given symbol. If not found return the given +-- default type. +type family FindElement (m :: Symbol) (ms :: [(Symbol, *)]) (d :: *) :: * where + FindElement m '[] d = d + FindElement m ('(m, o) ': ms) d = o + FindElement m ('(m', o) ': ms) d = FindElement m ms d + +-- | Result of a ancestor check. Basically a Bool type with a bit of +-- extra info in order to improve typechecker error messages. +data AncestorCheck t a = HasAncestor a t | DoesNotHaveRequiredAncestor Symbol t Symbol a + +-- | Check whether a type appears in a list. We specialize the +-- names/types a bit so the error messages are more informative. +type family CheckForAncestorType t (a :: *) (as :: [*]) :: AncestorCheck * * where + CheckForAncestorType t a '[] = + 'DoesNotHaveRequiredAncestor "Error: Required ancestor" a "not found for type" t + CheckForAncestorType t a (a ': as) = 'HasAncestor a t + CheckForAncestorType t a (b ': as) = CheckForAncestorType t a as + +-- | Check that a type is in the list of `GObjectParents` of another +-- `GObject`-derived type. +type family IsDescendantOf (parent :: *) (descendant :: *) :: Constraint where + -- Every object is defined to be a descendant of itself. + IsDescendantOf d d = () ~ () + IsDescendantOf p d = CheckForAncestorType d p (ParentTypes d) ~ 'HasAncestor p d + +-- | The direct parents of this object: its direct parent type, if any, +-- and the interfaces it implements. The interfaces inherited from +-- parent types can be omitted. +type family ParentTypes a :: [*] + +-- | The list of attributes defined for a given type. Each element of +-- the list is a tuple, with the first element of the tuple the name +-- of the attribute, and the second the type encoding the information +-- of the attribute. This type will be an instance of `AttrInfo`. +type family AttributeList a :: [(Symbol, *)] + +-- | Datatype returned when the attribute is not found, hopefully making +-- the resulting error messages somewhat clearer. +data UnknownAttribute (msg1 :: Symbol) (s :: Symbol) (msg2 :: Symbol) (o :: *) + +-- | Return the type encoding the attribute information for a given +-- type and attribute. +type family ResolveAttribute (s :: Symbol) (o :: *) :: * where + ResolveAttribute s o = FindElement s (AttributeList o) + (UnknownAttribute "Error: could not find attribute" s "for object" o) + +-- | Whether a given type is in the given list. If found, return +-- @success@, otherwise return @failure@. +type family IsElem (e :: Symbol) (es :: [(Symbol, *)]) (success :: k) (failure :: k) :: k where + IsElem e '[] success failure = failure + IsElem e ( '(e, t) ': es) success failure = success + IsElem e ( '(other, t) ': es) s f = IsElem e es s f + +-- | Isomorphic to Bool, but having some extra debug information. +data AttributeCheck a t = HasAttribute + | DoesNotHaveAttribute Symbol a Symbol t + +-- | A constraint imposing that the given object has the given attribute. +type family HasAttribute (attr :: Symbol) (o :: *) where + HasAttribute attr o = IsElem attr (AttributeList o) + 'HasAttribute + ('DoesNotHaveAttribute "Error: attribute" attr "not found for type" o) + ~ 'HasAttribute + +-- | A constraint that enforces that the given type has a given attribute. +class HasAttr (attr :: Symbol) (o :: *) +instance HasAttribute attr o => HasAttr attr o + +-- | The list of signals defined for a given type. Each element of +-- the list is a tuple, with the first element of the tuple the name +-- of the signal, and the second the type encoding the information of +-- the signal. This type will be an instance of `SignalInfo`. +type family SignalList a :: [(Symbol, *)] + +-- | Datatype returned when the signal is not found, hopefully making +-- the resulting error messages somewhat clearer. +data UnknownSignal (msg1 :: Symbol) (s :: Symbol) (msg2 :: Symbol) (o :: *) + +-- | Return the type encoding the signal information for a given +-- type and signal. +type family ResolveSignal (s :: Symbol) (o :: *) :: * where + ResolveSignal s o = FindElement s (SignalList o) + (UnknownSignal "Error: could not find signal" s "for object" o) + +-- | Isomorphic to Bool, but having some extra debug information. +data SignalCheck s t = HasSignal + | DoesNotHaveSignal Symbol s Symbol t + +-- | A constraint enforcing that the signal exists for the given +-- object, or one of its ancestors. +type family HasSignal (s :: Symbol) (o :: *) where + HasSignal s o = IsElem s (SignalList o) + 'HasSignal + ('DoesNotHaveSignal "Error: signal" s "not found for type" o) + ~ 'HasSignal diff --git a/src/Data/GI/Base/Properties.hsc b/src/Data/GI/Base/Properties.hsc new file mode 100644 --- /dev/null +++ b/src/Data/GI/Base/Properties.hsc @@ -0,0 +1,553 @@ +{-# LANGUAGE ScopedTypeVariables, GADTs, DataKinds, KindSignatures, +FlexibleInstances, MultiParamTypeClasses, TypeFamilies, PolyKinds, +EmptyDataDecls, ConstraintKinds #-} +{-# OPTIONS_GHC -Wall -fno-warn-orphans #-} + +module Data.GI.Base.Properties + ( new + + , PropertyNotify(..) + , GObjectNotifySignalInfo + + , setObjectPropertyString + , setObjectPropertyStringArray + , setObjectPropertyPtr + , setObjectPropertyCInt + , setObjectPropertyCUInt + , setObjectPropertyInt64 + , setObjectPropertyUInt64 + , setObjectPropertyFloat + , setObjectPropertyDouble + , setObjectPropertyBool + , setObjectPropertyGType + , setObjectPropertyObject + , setObjectPropertyBoxed + , setObjectPropertyEnum + , setObjectPropertyFlags + , setObjectPropertyVariant + , setObjectPropertyByteArray + , setObjectPropertyPtrGList + , setObjectPropertyHash + + , getObjectPropertyString + , getObjectPropertyStringArray + , getObjectPropertyPtr + , getObjectPropertyCInt + , getObjectPropertyCUInt + , getObjectPropertyInt64 + , getObjectPropertyUInt64 + , getObjectPropertyFloat + , getObjectPropertyDouble + , getObjectPropertyBool + , getObjectPropertyGType + , getObjectPropertyObject + , getObjectPropertyBoxed + , getObjectPropertyEnum + , getObjectPropertyFlags + , getObjectPropertyVariant + , getObjectPropertyByteArray + , getObjectPropertyPtrGList + , getObjectPropertyHash + + , constructObjectPropertyString + , constructObjectPropertyStringArray + , constructObjectPropertyPtr + , constructObjectPropertyCInt + , constructObjectPropertyCUInt + , constructObjectPropertyInt64 + , constructObjectPropertyUInt64 + , constructObjectPropertyFloat + , constructObjectPropertyDouble + , constructObjectPropertyBool + , constructObjectPropertyGType + , constructObjectPropertyObject + , constructObjectPropertyBoxed + , constructObjectPropertyEnum + , constructObjectPropertyFlags + , constructObjectPropertyVariant + , constructObjectPropertyByteArray + , constructObjectPropertyPtrGList + , constructObjectPropertyHash + ) where + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative ((<$>)) +#endif +import Control.Monad ((>=>)) + +import qualified Data.ByteString.Char8 as B +import Data.Text (Text) +import Data.Proxy (Proxy(..)) + +import Data.GI.Base.BasicTypes +import Data.GI.Base.BasicConversions +import Data.GI.Base.ManagedPtr +import Data.GI.Base.Attributes +import Data.GI.Base.GParamSpec (newGParamSpecFromPtr) +import Data.GI.Base.GValue +import Data.GI.Base.GVariant (newGVariantFromPtr) +import Data.GI.Base.Overloading (ResolveAttribute, HasAttr) +import Data.GI.Base.Signals (SignalConnectMode, SignalHandlerId, + connectSignalFunPtr, + SignalInfo(HaskellCallbackType, connectSignal)) + +import GHC.Exts (Constraint) +import GHC.TypeLits + +import Foreign hiding (new) +import Foreign.C + +#include + +foreign import ccall "dbg_g_object_newv" g_object_newv :: + GType -> CUInt -> Ptr a -> IO (Ptr b) + +-- | Construct a GObject given the constructor and a list of settable +-- attributes. AttrOps are always constructible, so we don't need to +-- enforce constraints here. +new :: forall o. GObject o => (ForeignPtr o -> o) -> + [AttrOp o 'AttrConstruct] -> IO o +new constructor attrs = do + props <- mapM construct attrs + let nprops = length props + params <- mallocBytes (nprops*gparameterSize) + fill params props + gtype <- gobjectType (undefined :: o) + result <- g_object_newv gtype (fromIntegral nprops) params + freeStrings nprops params + free params + -- Make sure that the GValues defining the GProperties are still + -- alive at this point (so, in particular, they are still alive when + -- g_object_newv is called). Without this the GHC garbage collector + -- may free the GValues before g_object_newv us called, which will + -- unref the referred to objects, which may drop the last reference + -- to the contained objects. g_object_newv then tries to access the + -- (now invalid) contents of the GValue, and mayhem ensues. + mapM_ (touchManagedPtr . snd) props + wrapObject constructor (result :: Ptr o) + where + resolve :: proxy attr -> Proxy (ResolveAttribute attr o) + resolve _ = Proxy + + construct :: AttrOp o 'AttrConstruct -> + IO (String, GValue) + construct (attr := x) = attrConstruct (resolve attr) x + construct (attr :=> x) = x >>= attrConstruct (resolve attr) + + gvalueSize = #size GValue + gparameterSize = #size GParameter + + -- Fill the given memory address with the contents of the array of + -- GParameters. + fill :: Ptr () -> [(String, GValue)] -> IO () + fill _ [] = return () + fill dataPtr ((str, gvalue):xs) = + do cstr <- newCString str + poke (castPtr dataPtr) cstr + withManagedPtr gvalue $ \gvalueptr -> + copyBytes (dataPtr `plusPtr` sizeOf nullPtr) gvalueptr gvalueSize + fill (dataPtr `plusPtr` gparameterSize) xs + + -- Free the strings in the GParameter array (the GValues will be + -- freed separately). + freeStrings :: Int -> Ptr () -> IO () + freeStrings 0 _ = return () + freeStrings n dataPtr = + do cstr <- peek (castPtr dataPtr) :: IO CString + free cstr + freeStrings (n-1) (dataPtr `plusPtr` gparameterSize) + +-- | Proxy for "notify::property-name" signals. +data PropertyNotify (s :: Symbol) (propName :: Symbol) (constraint :: * -> Constraint) where + PropertyNotify :: KnownSymbol propName => proxy propName -> + PropertyNotify "notify::[property]" propName (HasAttr propName) + +-- | Connection information for a "notify" signal indicating that a +-- specific property changed (see `PropertyNotify` for the relevant +-- constructor). +data GObjectNotifySignalInfo +instance SignalInfo GObjectNotifySignalInfo where + type HaskellCallbackType GObjectNotifySignalInfo = GObjectNotifyCallback + connectSignal = connectGObjectNotify + +-- | Type for a `GObject` `notify` callback. +type GObjectNotifyCallback = GParamSpec -> IO () + +gobjectNotifyCallbackWrapper :: + GObjectNotifyCallback -> Ptr () -> Ptr GParamSpec -> Ptr () -> IO () +gobjectNotifyCallbackWrapper _cb _ pspec _ = do + pspec' <- newGParamSpecFromPtr pspec + _cb pspec' + +type GObjectNotifyCallbackC = Ptr () -> Ptr GParamSpec -> Ptr () -> IO () + +foreign import ccall "wrapper" + mkGObjectNotifyCallback :: GObjectNotifyCallbackC -> IO (FunPtr GObjectNotifyCallbackC) + +-- | Connect the given notify callback for a GObject. +connectGObjectNotify :: forall o i proxy propName constraint. + (GObject o, constraint o, KnownSymbol propName) => + proxy (i :: *) (propName :: Symbol) (constraint :: * -> Constraint) -> + o -> GObjectNotifyCallback -> + SignalConnectMode -> IO SignalHandlerId +connectGObjectNotify _ obj cb after = do + cb' <- mkGObjectNotifyCallback (gobjectNotifyCallbackWrapper cb) + let signalName = "notify::" ++ symbolVal (Proxy :: Proxy propName) + connectSignalFunPtr obj signalName cb' after + +foreign import ccall "g_object_set_property" g_object_set_property :: + Ptr a -> CString -> Ptr GValue -> IO () + +setObjectProperty :: GObject a => a -> String -> b -> + (GValue -> b -> IO ()) -> GType -> IO () +setObjectProperty obj propName propValue setter (GType gtype) = do + gvalue <- buildGValue (GType gtype) setter propValue + withManagedPtr obj $ \objPtr -> + withCString propName $ \cPropName -> + withManagedPtr gvalue $ \gvalueptr -> + g_object_set_property objPtr cPropName gvalueptr + +foreign import ccall "g_object_get_property" g_object_get_property :: + Ptr a -> CString -> Ptr GValue -> IO () + +getObjectProperty :: GObject a => a -> String -> + (GValue -> IO b) -> GType -> IO b +getObjectProperty obj propName getter gtype = do + gvalue <- newGValue gtype + withManagedPtr obj $ \objPtr -> + withCString propName $ \cPropName -> + withManagedPtr gvalue $ \gvalueptr -> + g_object_get_property objPtr cPropName gvalueptr + getter gvalue + +constructObjectProperty :: String -> b -> (GValue -> b -> IO ()) -> + GType -> IO (String, GValue) +constructObjectProperty propName propValue setter gtype = do + gvalue <- buildGValue gtype setter propValue + return (propName, gvalue) + +setObjectPropertyString :: GObject a => + a -> String -> Text -> IO () +setObjectPropertyString obj propName str = + setObjectProperty obj propName str set_string (GType #const G_TYPE_STRING) + +constructObjectPropertyString :: String -> Text -> + IO (String, GValue) +constructObjectPropertyString propName str = + constructObjectProperty propName str set_string (GType #const G_TYPE_STRING) + +getObjectPropertyString :: GObject a => + a -> String -> IO Text +getObjectPropertyString obj propName = + getObjectProperty obj propName get_string (GType #const G_TYPE_STRING) + +setObjectPropertyPtr :: GObject a => + a -> String -> Ptr b -> IO () +setObjectPropertyPtr obj propName ptr = + setObjectProperty obj propName ptr set_pointer (GType #const G_TYPE_POINTER) + +constructObjectPropertyPtr :: String -> Ptr b -> + IO (String, GValue) +constructObjectPropertyPtr propName ptr = + constructObjectProperty propName ptr set_pointer (GType #const G_TYPE_POINTER) + +getObjectPropertyPtr :: GObject a => + a -> String -> IO (Ptr b) +getObjectPropertyPtr obj propName = + getObjectProperty obj propName get_pointer (GType #const G_TYPE_POINTER) + +setObjectPropertyCInt :: GObject a => + a -> String -> Int32 -> IO () +setObjectPropertyCInt obj propName int = + setObjectProperty obj propName int set_int32 (GType #const G_TYPE_INT) + +constructObjectPropertyCInt :: String -> Int32 -> + IO (String, GValue) +constructObjectPropertyCInt propName int = + constructObjectProperty propName int set_int32 (GType #const G_TYPE_INT) + +getObjectPropertyCInt :: GObject a => a -> String -> IO Int32 +getObjectPropertyCInt obj propName = + getObjectProperty obj propName get_int32 (GType #const G_TYPE_INT) + +setObjectPropertyCUInt :: GObject a => + a -> String -> Word32 -> IO () +setObjectPropertyCUInt obj propName uint = + setObjectProperty obj propName uint set_uint32 (GType #const G_TYPE_UINT) + +constructObjectPropertyCUInt :: String -> Word32 -> + IO (String, GValue) +constructObjectPropertyCUInt propName uint = + constructObjectProperty propName uint set_uint32 (GType #const G_TYPE_UINT) + +getObjectPropertyCUInt :: GObject a => a -> String -> IO Word32 +getObjectPropertyCUInt obj propName = + getObjectProperty obj propName get_uint32 (GType #const G_TYPE_UINT) + +setObjectPropertyInt64 :: GObject a => + a -> String -> Int64 -> IO () +setObjectPropertyInt64 obj propName int64 = + setObjectProperty obj propName int64 set_int64 (GType #const G_TYPE_INT64) + +constructObjectPropertyInt64 :: String -> Int64 -> + IO (String, GValue) +constructObjectPropertyInt64 propName int64 = + constructObjectProperty propName int64 set_int64 (GType #const G_TYPE_INT64) + +getObjectPropertyInt64 :: GObject a => a -> String -> IO Int64 +getObjectPropertyInt64 obj propName = + getObjectProperty obj propName get_int64 (GType #const G_TYPE_INT64) + +setObjectPropertyUInt64 :: GObject a => + a -> String -> Word64 -> IO () +setObjectPropertyUInt64 obj propName uint64 = + setObjectProperty obj propName uint64 set_uint64 (GType #const G_TYPE_UINT64) + +constructObjectPropertyUInt64 :: String -> Word64 -> + IO (String, GValue) +constructObjectPropertyUInt64 propName uint64 = + constructObjectProperty propName uint64 set_uint64 (GType #const G_TYPE_UINT64) + +getObjectPropertyUInt64 :: GObject a => a -> String -> IO Word64 +getObjectPropertyUInt64 obj propName = + getObjectProperty obj propName get_uint64 (GType #const G_TYPE_UINT64) + +setObjectPropertyFloat :: GObject a => + a -> String -> Float -> IO () +setObjectPropertyFloat obj propName float = + setObjectProperty obj propName float set_float (GType #const G_TYPE_FLOAT) + +constructObjectPropertyFloat :: String -> Float -> + IO (String, GValue) +constructObjectPropertyFloat propName float = + constructObjectProperty propName float set_float (GType #const G_TYPE_FLOAT) + +getObjectPropertyFloat :: GObject a => + a -> String -> IO Float +getObjectPropertyFloat obj propName = + getObjectProperty obj propName get_float (GType #const G_TYPE_FLOAT) + +setObjectPropertyDouble :: GObject a => + a -> String -> Double -> IO () +setObjectPropertyDouble obj propName double = + setObjectProperty obj propName double set_double (GType #const G_TYPE_DOUBLE) + +constructObjectPropertyDouble :: String -> Double -> + IO (String, GValue) +constructObjectPropertyDouble propName double = + constructObjectProperty propName double set_double (GType #const G_TYPE_DOUBLE) + +getObjectPropertyDouble :: GObject a => + a -> String -> IO Double +getObjectPropertyDouble obj propName = + getObjectProperty obj propName get_double (GType #const G_TYPE_DOUBLE) + +setObjectPropertyBool :: GObject a => + a -> String -> Bool -> IO () +setObjectPropertyBool obj propName bool = + setObjectProperty obj propName bool set_boolean (GType #const G_TYPE_BOOLEAN) + +constructObjectPropertyBool :: String -> Bool -> IO (String, GValue) +constructObjectPropertyBool propName bool = + constructObjectProperty propName bool set_boolean (GType #const G_TYPE_BOOLEAN) + +getObjectPropertyBool :: GObject a => a -> String -> IO Bool +getObjectPropertyBool obj propName = + getObjectProperty obj propName get_boolean (GType #const G_TYPE_BOOLEAN) + +setObjectPropertyGType :: GObject a => + a -> String -> GType -> IO () +setObjectPropertyGType obj propName gtype = + setObjectProperty obj propName gtype set_gtype (GType #const G_TYPE_GTYPE) + +constructObjectPropertyGType :: String -> GType -> IO (String, GValue) +constructObjectPropertyGType propName bool = + constructObjectProperty propName bool set_gtype (GType #const G_TYPE_GTYPE) + +getObjectPropertyGType :: GObject a => a -> String -> IO GType +getObjectPropertyGType obj propName = + getObjectProperty obj propName get_gtype (GType #const G_TYPE_GTYPE) + +setObjectPropertyObject :: (GObject a, GObject b) => + a -> String -> b -> IO () +setObjectPropertyObject obj propName object = do + gtype <- gobjectType object + withManagedPtr object $ \objectPtr -> + setObjectProperty obj propName objectPtr set_object gtype + +constructObjectPropertyObject :: GObject a => + String -> a -> IO (String, GValue) +constructObjectPropertyObject propName object = do + gtype <- gobjectType object + withManagedPtr object $ \objectPtr -> + constructObjectProperty propName objectPtr set_object gtype + +getObjectPropertyObject :: forall a b. (GObject a, GObject b) => + a -> String -> (ForeignPtr b -> b) -> IO b +getObjectPropertyObject obj propName constructor = do + gtype <- gobjectType (undefined :: b) + getObjectProperty obj propName + (\val -> (get_object val :: IO (Ptr b)) + >>= newObject constructor) + gtype + +setObjectPropertyBoxed :: (GObject a, BoxedObject b) => + a -> String -> b -> IO () +setObjectPropertyBoxed obj propName boxed = do + gtype <- boxedType boxed + withManagedPtr boxed $ \boxedPtr -> + setObjectProperty obj propName boxedPtr set_boxed gtype + +constructObjectPropertyBoxed :: (BoxedObject a) => String -> a -> + IO (String, GValue) +constructObjectPropertyBoxed propName boxed = do + gtype <- boxedType boxed + withManagedPtr boxed $ \boxedPtr -> + constructObjectProperty propName boxedPtr set_boxed gtype + +getObjectPropertyBoxed :: forall a b. (GObject a, BoxedObject b) => + a -> String -> (ForeignPtr b -> b) -> IO b +getObjectPropertyBoxed obj propName constructor = do + gtype <- boxedType (undefined :: b) + getObjectProperty obj propName (get_boxed >=> newBoxed constructor) gtype + +setObjectPropertyStringArray :: GObject a => + a -> String -> [Text] -> IO () +setObjectPropertyStringArray obj propName strv = do + cStrv <- packZeroTerminatedUTF8CArray strv + setObjectProperty obj propName cStrv set_boxed (GType #const G_TYPE_STRV) + mapZeroTerminatedCArray free cStrv + free cStrv + +constructObjectPropertyStringArray :: String -> [Text] -> + IO (String, GValue) +constructObjectPropertyStringArray propName strv = do + cStrv <- packZeroTerminatedUTF8CArray strv + result <- constructObjectProperty propName cStrv set_boxed (GType #const G_TYPE_STRV) + mapZeroTerminatedCArray free cStrv + free cStrv + return result + +getObjectPropertyStringArray :: GObject a => + a -> String -> IO [Text] +getObjectPropertyStringArray obj propName = + getObjectProperty obj propName + (get_boxed >=> unpackZeroTerminatedUTF8CArray . castPtr) + (GType #const G_TYPE_STRV) + +setObjectPropertyEnum :: (GObject a, Enum b, BoxedEnum b) => + a -> String -> b -> IO () +setObjectPropertyEnum obj propName enum = do + gtype <- boxedEnumType enum + let cEnum = (fromIntegral . fromEnum) enum + setObjectProperty obj propName cEnum set_enum gtype + +constructObjectPropertyEnum :: (Enum a, BoxedEnum a) => + String -> a -> IO (String, GValue) +constructObjectPropertyEnum propName enum = do + gtype <- boxedEnumType enum + let cEnum = (fromIntegral . fromEnum) enum + constructObjectProperty propName cEnum set_enum gtype + +getObjectPropertyEnum :: forall a b. (GObject a, + Enum b, BoxedEnum b) => + a -> String -> IO b +getObjectPropertyEnum obj propName = do + gtype <- boxedEnumType (undefined :: b) + getObjectProperty obj propName + (\val -> toEnum . fromIntegral <$> get_enum val) + gtype + +setObjectPropertyFlags :: (IsGFlag b, GObject a) => + a -> String -> [b] -> IO () +setObjectPropertyFlags obj propName flags = + let cFlags = gflagsToWord flags + in setObjectProperty obj propName cFlags set_flags (GType #const G_TYPE_FLAGS) + +constructObjectPropertyFlags :: IsGFlag a => String -> [a] -> + IO (String, GValue) +constructObjectPropertyFlags propName flags = + let cFlags = gflagsToWord flags + in constructObjectProperty propName cFlags set_flags (GType #const G_TYPE_FLAGS) + +getObjectPropertyFlags :: (GObject a, IsGFlag b) => + a -> String -> IO [b] +getObjectPropertyFlags obj propName = + getObjectProperty obj propName + (\val -> wordToGFlags <$> get_flags val) + (GType #const G_TYPE_FLAGS) + +setObjectPropertyVariant :: GObject a => + a -> String -> GVariant -> IO () +setObjectPropertyVariant obj propName variant = + withManagedPtr variant $ \variantPtr -> + setObjectProperty obj propName variantPtr set_variant + (GType #const G_TYPE_VARIANT) + +constructObjectPropertyVariant :: String -> GVariant -> IO (String, GValue) +constructObjectPropertyVariant propName obj = + withManagedPtr obj $ \objPtr -> + constructObjectProperty propName objPtr set_variant + (GType #const G_TYPE_VARIANT) + +getObjectPropertyVariant :: GObject a => a -> String -> + IO GVariant +getObjectPropertyVariant obj propName = + getObjectProperty obj propName (get_variant >=> newGVariantFromPtr) + (GType #const G_TYPE_VARIANT) + +setObjectPropertyByteArray :: GObject a => + a -> String -> B.ByteString -> IO () +setObjectPropertyByteArray obj propName bytes = do + packed <- packGByteArray bytes + setObjectProperty obj propName packed set_boxed (GType #const G_TYPE_BYTE_ARRAY) + unrefGByteArray packed + +constructObjectPropertyByteArray :: String -> B.ByteString -> + IO (String, GValue) +constructObjectPropertyByteArray propName bytes = do + packed <- packGByteArray bytes + result <- constructObjectProperty propName packed + set_boxed (GType #const G_TYPE_BYTE_ARRAY) + unrefGByteArray packed + return result + +getObjectPropertyByteArray :: GObject a => + a -> String -> IO B.ByteString +getObjectPropertyByteArray obj propName = + getObjectProperty obj propName (get_boxed >=> unpackGByteArray) + (GType #const G_TYPE_BYTE_ARRAY) + +setObjectPropertyPtrGList :: GObject a => + a -> String -> [Ptr b] -> IO () +setObjectPropertyPtrGList obj propName ptrs = do + packed <- packGList ptrs + setObjectProperty obj propName packed set_boxed (GType #const G_TYPE_POINTER) + g_list_free packed + +constructObjectPropertyPtrGList :: String -> [Ptr a] -> + IO (String, GValue) +constructObjectPropertyPtrGList propName ptrs = do + packed <- packGList ptrs + result <- constructObjectProperty propName packed + set_boxed (GType #const G_TYPE_POINTER) + g_list_free packed + return result + +getObjectPropertyPtrGList :: GObject a => + a -> String -> IO [Ptr b] +getObjectPropertyPtrGList obj propName = + getObjectProperty obj propName (get_pointer >=> unpackGList) + (GType #const G_TYPE_POINTER) + +setObjectPropertyHash :: GObject a => a -> String -> b -> IO () +setObjectPropertyHash = + error $ "Setting GHashTable properties not supported yet." + +constructObjectPropertyHash :: String -> b -> IO (String, GValue) +constructObjectPropertyHash = + error $ "Constructing GHashTable properties not supported yet." + +getObjectPropertyHash :: GObject a => a -> String -> IO b +getObjectPropertyHash = + error $ "Getting GHashTable properties not supported yet." diff --git a/src/Data/GI/Base/ShortPrelude.hs b/src/Data/GI/Base/ShortPrelude.hs new file mode 100644 --- /dev/null +++ b/src/Data/GI/Base/ShortPrelude.hs @@ -0,0 +1,30 @@ +-- | The Haskell Prelude exports a number of symbols that can easily +-- collide with functions appearing in bindings. The generated code +-- requires just a small subset of the functions in the Prelude, which +-- we reexport explicitly here. +module Data.GI.Base.ShortPrelude + ( Enum(fromEnum, toEnum) + , Show(..) + , Eq(..) + , IO + , Monad(..) + , Maybe(..) + , (.) + , ($) + , (++) + , (=<<) + , Bool(..) + , Float + , Double + , undefined + , error + , map + , length + , mapM + , mapM_ + , when + , fromIntegral + , realToFrac + ) where + +import Control.Monad (when) diff --git a/src/Data/GI/Base/Signals.hsc b/src/Data/GI/Base/Signals.hsc new file mode 100644 --- /dev/null +++ b/src/Data/GI/Base/Signals.hsc @@ -0,0 +1,105 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE FlexibleInstances #-} + +-- | Routines for connecting `GObject`s to signals. +module Data.GI.Base.Signals + ( SignalConnectMode(..), + connectSignalFunPtr, + on, + after, + SignalHandlerId, + SignalInfo(..) + ) where + +import Foreign +import Foreign.C + +import GHC.Exts (Constraint) +import GHC.TypeLits + +import Data.GI.Base.BasicTypes +import Data.GI.Base.ManagedPtr (withManagedPtr) +import Data.GI.Base.Overloading (HasSignal, ResolveSignal) +import Data.GI.Base.Utils (safeFreeFunPtrPtr) + +#include + +-- | Type of a `GObject` signal handler id. +type SignalHandlerId = #type gulong + +-- | A proxy for passing on the signal information. +data SignalProxy (s :: *) (e :: Symbol) (c :: * -> Constraint) = SignalProxy + +-- | Information about an overloaded signal. +class SignalInfo (info :: *) where + type HaskellCallbackType info + -- | Connect a Haskell function to a signal of the given `GObject`, + -- specifying whether the handler will be called before or after + -- the default handler. + connectSignal :: (KnownSymbol extra, GObject o, constraint o) => + SignalProxy info extra constraint -> + o -> + HaskellCallbackType info -> + SignalConnectMode -> + IO SignalHandlerId + +-- | Whether to connect a handler to a signal with `connectSignal` so +-- that it runs before/after the default handler for the given signal. +data SignalConnectMode = SignalConnectBefore -- ^ Run before the default handler. + | SignalConnectAfter -- ^ Run after the default handler. + +-- | Same as `connectSignal`, specifying from the beginning that the +-- handler is to be run before the default handler. +-- +-- > on = connectSignal SignalConnectBefore +on :: forall signal extra o info constraint proxy. + (GObject o, + HasSignal signal o, info ~ ResolveSignal signal o, SignalInfo info, + KnownSymbol extra, constraint o) => + o -> proxy (signal :: Symbol) (extra :: Symbol) (constraint :: * -> Constraint) + -> HaskellCallbackType info -> IO SignalHandlerId +on o p c = connectSignal (resolve p) o c SignalConnectBefore + where resolve :: proxy signal extra constraint -> + SignalProxy (ResolveSignal signal o) extra constraint + resolve _ = SignalProxy + +-- | Connect a signal to a handler, running the handler after the default one. +-- +-- > after = connectSignal SignalConnectAfter +after :: forall signal extra o info constraint proxy. + (GObject o, + HasSignal signal o, info ~ ResolveSignal signal o, SignalInfo info, + KnownSymbol extra, constraint o) => + o -> proxy (signal :: Symbol) (extra :: Symbol) (constraint :: * -> Constraint) + -> HaskellCallbackType info -> IO SignalHandlerId +after o p c = connectSignal (resolve p) o c SignalConnectAfter + where resolve :: proxy signal extra constraint -> + SignalProxy (ResolveSignal signal o) extra constraint + resolve _ = SignalProxy + +-- Connecting GObjects to signals +foreign import ccall "g_signal_connect_data" g_signal_connect_data :: + Ptr a -> -- instance + CString -> -- detailed_signal + FunPtr b -> -- c_handler + Ptr () -> -- data + FunPtr c -> -- destroy_data + CUInt -> -- connect_flags + IO SignalHandlerId + +-- | Connect a signal to a handler, given as a `FunPtr`. +connectSignalFunPtr :: GObject o => + o -> String -> FunPtr a -> SignalConnectMode -> IO SignalHandlerId +connectSignalFunPtr object signal fn mode = do + let flags = case mode of + SignalConnectAfter -> 1 + SignalConnectBefore -> 0 + withCString signal $ \csignal -> + withManagedPtr object $ \objPtr -> + g_signal_connect_data objPtr csignal fn (castFunPtrToPtr fn) safeFreeFunPtrPtr flags diff --git a/src/Data/GI/Base/Utils.hsc b/src/Data/GI/Base/Utils.hsc new file mode 100644 --- /dev/null +++ b/src/Data/GI/Base/Utils.hsc @@ -0,0 +1,156 @@ +{-# LANGUAGE ScopedTypeVariables, TupleSections #-} +{- | Assorted utility functions for bindings. -} +module Data.GI.Base.Utils + ( whenJust + , maybeM + , maybeFromPtr + , mapFirst + , mapFirstA + , mapSecond + , mapSecondA + , convertIfNonNull + , callocBytes + , callocBoxedBytes + , allocBytes + , allocMem + , freeMem + , ptr_to_g_free + , memcpy + , safeFreeFunPtr + , safeFreeFunPtrPtr + , maybeReleaseFunPtr + ) where + +#include + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative (Applicative, pure, (<$>), (<*>)) +#endif +import Control.Monad (void) + +import Data.Word + +import Foreign (peek) +import Foreign.C.Types (CSize(..)) +import Foreign.Ptr (Ptr, nullPtr, FunPtr, freeHaskellFunPtr) +import Foreign.Storable (Storable(..)) + +import Data.GI.Base.BasicTypes (GType(..), CGType, BoxedObject(..)) + +-- | When the given value is of "Just a" form, execute the given action, +-- otherwise do nothing. +whenJust :: Monad m => Maybe a -> (a -> m ()) -> m () +whenJust (Just v) f = f v +whenJust Nothing _ = return () + +-- | Like `Control.Monad.maybe`, but for actions on a monad, and with +-- slightly different argument order. +maybeM :: Monad m => b -> Maybe a -> (a -> m b) -> m b +maybeM d Nothing _ = return d +maybeM _ (Just v) action = action v + +-- | Check if the pointer is `nullPtr`, and wrap it on a `Maybe` +-- accordingly. +maybeFromPtr :: Ptr a -> Maybe (Ptr a) +maybeFromPtr ptr = if ptr == nullPtr + then Nothing + else Just ptr + +-- | Given a function and a list of two-tuples, apply the function to +-- every first element of the tuples. +mapFirst :: (a -> c) -> [(a,b)] -> [(c,b)] +mapFirst _ [] = [] +mapFirst f ((x,y) : rest) = (f x, y) : mapFirst f rest + +-- | Same for the second element. +mapSecond :: (b -> c) -> [(a,b)] -> [(a,c)] +mapSecond _ [] = [] +mapSecond f ((x,y) : rest) = (x, f y) : mapSecond f rest + +-- | Applicative version of `mapFirst`. +mapFirstA :: Applicative f => (a -> f c) -> [(a,b)] -> f [(c,b)] +mapFirstA _ [] = pure [] +mapFirstA f ((x,y) : rest) = (:) <$> ((,y) <$> f x) <*> mapFirstA f rest + +-- | Applicative version of `mapSecond`. +mapSecondA :: Applicative f => (b -> f c) -> [(a,b)] -> f [(a,c)] +mapSecondA _ [] = pure [] +mapSecondA f ((x,y) : rest) = (:) <$> ((x,) <$> f y) <*> mapSecondA f rest + +-- | Apply the given conversion action to the given pointer if it is +-- non-NULL, otherwise return `Nothing`. +convertIfNonNull :: Ptr a -> (Ptr a -> IO b) -> IO (Maybe b) +convertIfNonNull ptr convert = if ptr == nullPtr + then return Nothing + else Just <$> convert ptr + +foreign import ccall "g_malloc0" g_malloc0 :: + #{type gsize} -> IO (Ptr a) + +-- | Make a zero-filled allocation using the GLib allocator. +{-# INLINE callocBytes #-} +callocBytes :: Int -> IO (Ptr a) +callocBytes n = g_malloc0 (fromIntegral n) + +foreign import ccall "g_boxed_copy" g_boxed_copy :: + CGType -> Ptr a -> IO (Ptr a) + +-- | Make a zero filled allocation of n bytes for a boxed object. The +-- difference with a normal callocBytes is that the returned memory is +-- allocated using whatever memory allocator g_boxed_copy uses, which +-- in particular may well be different from a plain g_malloc. In +-- particular g_slice_alloc is often used for allocating boxed +-- objects, which are then freed using g_slice_free. +callocBoxedBytes :: forall a. BoxedObject a => Int -> IO (Ptr a) +callocBoxedBytes n = do + ptr <- callocBytes n + GType cgtype <- boxedType (undefined :: a) + result <- g_boxed_copy cgtype ptr + freeMem ptr + return result + +foreign import ccall "g_malloc" g_malloc :: + #{type gsize} -> IO (Ptr a) + +-- | Allocate the given number of bytes using the GLib allocator. +{-# INLINE allocBytes #-} +allocBytes :: Integral a => a -> IO (Ptr b) +allocBytes n = g_malloc (fromIntegral n) + +-- | Allocate space for the given `Storable` using the GLib allocator. +{-# INLINE allocMem #-} +allocMem :: forall a. Storable a => IO (Ptr a) +allocMem = g_malloc $ (fromIntegral . sizeOf) (undefined :: a) + +-- | A wrapped for `g_free`. +foreign import ccall "g_free" freeMem :: Ptr a -> IO () + +-- | Pointer to `g_free`. +foreign import ccall "&g_free" ptr_to_g_free :: FunPtr (Ptr a -> IO ()) + +foreign import ccall unsafe "string.h memcpy" _memcpy :: Ptr a -> Ptr b -> CSize -> IO (Ptr ()) + +-- | Copy memory into a destination (in the first argument) from a +-- source (in the second argument). +{-# INLINE memcpy #-} +memcpy :: Ptr a -> Ptr b -> Int -> IO () +memcpy dest src n = void $ _memcpy dest src (fromIntegral n) + +-- | Same as freeHaskellFunPtr, but it does nothing when given a +-- nullPtr. +foreign import ccall "safeFreeFunPtr" safeFreeFunPtr :: + Ptr a -> IO () + +-- | A pointer to `safeFreeFunPtr`. +foreign import ccall "& safeFreeFunPtr" safeFreeFunPtrPtr :: + FunPtr (Ptr a -> IO ()) + +-- | If given a pointer to the memory location, free the `FunPtr` at +-- that location, and then the pointer itself. Useful for freeing the +-- memory associated to callbacks which are called just once, with no +-- destroy notification. +maybeReleaseFunPtr :: Maybe (Ptr (FunPtr a)) -> IO () +maybeReleaseFunPtr Nothing = return () +maybeReleaseFunPtr (Just f) = do + peek f >>= freeHaskellFunPtr + freeMem f diff --git a/src/c/hsgclosure.c b/src/c/hsgclosure.c new file mode 100644 --- /dev/null +++ b/src/c/hsgclosure.c @@ -0,0 +1,94 @@ +#define _GNU_SOURCE + +/* GHC's semi-public Rts API */ +#include + +#include + +#include + +int check_object_type(void *instance, GType type) +{ + int result; + + if (instance != NULL) { + result = !!G_TYPE_CHECK_INSTANCE_TYPE(instance, type); + } else { + result = 0; + fprintf(stderr, "Check failed: got a null pointer\n"); + } + + return result; +} + +static int print_debug_info () +{ + static int __print_debug_info = -1; + + if (__print_debug_info == -1) { + __print_debug_info = secure_getenv ("HASKELL_GI_DEBUG_MEM") != NULL; + } + + return __print_debug_info; +} + +/* Auxiliary function for freeing boxed types */ +void boxed_free_helper (GType *gtype, void *boxed) +{ + if (print_debug_info()) { + fprintf(stderr, "Freeing a boxed object at %p\n", boxed); + fprintf(stderr, "\tIt is of type %s\n", g_type_name(*gtype)); + } + + g_boxed_free (*gtype, boxed); + g_free (gtype); + + if (print_debug_info()) { + fprintf(stderr, "\tdone\n"); + } +} + +void dbg_g_object_unref (GObject *obj) +{ + GType gtype; + + if (print_debug_info()) { + fprintf(stderr, "Freeing a GObject at %p\n", obj); + gtype = G_TYPE_FROM_INSTANCE (obj); + fprintf(stderr, "\tIt is of type %s\n", g_type_name(gtype)); + fprintf(stderr, "\tIts refcount before unref is %d\n", + (int)obj->ref_count); + } + + g_object_unref(obj); + + if (print_debug_info()) { + fprintf(stderr, "\tdone\n"); + } +} + +gpointer dbg_g_object_newv (GType gtype, guint n_params, GParameter *params) +{ + gpointer result; + + if (print_debug_info()) { + fprintf(stderr, "Creating a new GObject of type %s\n", + g_type_name(gtype)); + } + + result = g_object_newv (gtype, n_params, params); + + if (print_debug_info()) { + fprintf(stderr, "\tdone, got a pointer at %p\n", result); + } + + return result; +} + +/* Same as freeHaskellFunctionPtr, but it does nothing when given a + null pointer, instead of crashing */ +void safeFreeFunPtr(void *ptr) +{ + if (ptr != NULL) + freeHaskellFunctionPtr(ptr); +}