gi-gtk-hs-0.3.9/0000755000000000000000000000000007346545000011506 5ustar0000000000000000gi-gtk-hs-0.3.9/LICENSE0000644000000000000000000006363107346545000012524 0ustar0000000000000000 GNU LESSER GENERAL PUBLIC LICENSE Version 2.1, February 1999 Copyright (C) 1991, 1999 Free Software Foundation, Inc. 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. [This is the first released version of the Lesser GPL. It also counts as the successor of the GNU Library Public License, version 2, hence the version number 2.1.] Preamble The licenses for most software are designed to take away your freedom to share and change it. By contrast, the GNU General Public Licenses are intended to guarantee your freedom to share and change free software--to make sure the software is free for all its users. This license, the Lesser General Public License, applies to some specially designated software packages--typically libraries--of the Free Software Foundation and other authors who decide to use it. You can use it too, but we suggest you first think carefully about whether this license or the ordinary General Public License is the better strategy to use in any particular case, based on the explanations below. When we speak of free software, we are referring to freedom of use, not price. Our General Public Licenses are designed to make sure that you have the freedom to distribute copies of free software (and charge for this service if you wish); that you receive source code or can get it if you want it; that you can change the software and use pieces of it in new free programs; and that you are informed that you can do these things. To protect your rights, we need to make restrictions that forbid distributors to deny you these rights or to ask you to surrender these rights. These restrictions translate to certain responsibilities for you if you distribute copies of the library or if you modify it. For example, if you distribute copies of the library, whether gratis or for a fee, you must give the recipients all the rights that we gave you. You must make sure that they, too, receive or can get the source code. If you link other code with the library, you must provide complete object files to the recipients, so that they can relink them with the library after making changes to the library and recompiling it. And you must show them these terms so they know their rights. We protect your rights with a two-step method: (1) we copyright the library, and (2) we offer you this license, which gives you legal permission to copy, distribute and/or modify the library. To protect each distributor, we want to make it very clear that there is no warranty for the free library. Also, if the library is modified by someone else and passed on, the recipients should know that what they have is not the original version, so that the original author's reputation will not be affected by problems that might be introduced by others. Finally, software patents pose a constant threat to the existence of any free program. We wish to make sure that a company cannot effectively restrict the users of a free program by obtaining a restrictive license from a patent holder. Therefore, we insist that any patent license obtained for a version of the library must be consistent with the full freedom of use specified in this license. Most GNU software, including some libraries, is covered by the ordinary GNU General Public License. This license, the GNU Lesser General Public License, applies to certain designated libraries, and is quite different from the ordinary General Public License. We use this license for certain libraries in order to permit linking those libraries into non-free programs. When a program is linked with a library, whether statically or using a shared library, the combination of the two is legally speaking a combined work, a derivative of the original library. The ordinary General Public License therefore permits such linking only if the entire combination fits its criteria of freedom. The Lesser General Public License permits more lax criteria for linking other code with the library. We call this license the "Lesser" General Public License because it does Less to protect the user's freedom than the ordinary General Public License. It also provides other free software developers Less of an advantage over competing non-free programs. These disadvantages are the reason we use the ordinary General Public License for many libraries. However, the Lesser license provides advantages in certain special circumstances. For example, on rare occasions, there may be a special need to encourage the widest possible use of a certain library, so that it becomes a de-facto standard. To achieve this, non-free programs must be allowed to use the library. A more frequent case is that a free library does the same job as widely used non-free libraries. In this case, there is little to gain by limiting the free library to free software only, so we use the Lesser General Public License. In other cases, permission to use a particular library in non-free programs enables a greater number of people to use a large body of free software. For example, permission to use the GNU C Library in non-free programs enables many more people to use the whole GNU operating system, as well as its variant, the GNU/Linux operating system. Although the Lesser General Public License is Less protective of the users' freedom, it does ensure that the user of a program that is linked with the Library has the freedom and the wherewithal to run that program using a modified version of the Library. The precise terms and conditions for copying, distribution and modification follow. Pay close attention to the difference between a "work based on the library" and a "work that uses the library". The former contains code derived from the library, whereas the latter must be combined with the library in order to run. GNU LESSER GENERAL PUBLIC LICENSE TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 0. This License Agreement applies to any software library or other program which contains a notice placed by the copyright holder or other authorized party saying it may be distributed under the terms of this Lesser General Public License (also called "this License"). Each licensee is addressed as "you". A "library" means a collection of software functions and/or data prepared so as to be conveniently linked with application programs (which use some of those functions and data) to form executables. The "Library", below, refers to any such software library or work which has been distributed under these terms. A "work based on the Library" means either the Library or any derivative work under copyright law: that is to say, a work containing the Library or a portion of it, either verbatim or with modifications and/or translated straightforwardly into another language. (Hereinafter, translation is included without limitation in the term "modification".) "Source code" for a work means the preferred form of the work for making modifications to it. For a library, complete source code means all the source code for all modules it contains, plus any associated interface definition files, plus the scripts used to control compilation and installation of the library. Activities other than copying, distribution and modification are not covered by this License; they are outside its scope. The act of running a program using the Library is not restricted, and output from such a program is covered only if its contents constitute a work based on the Library (independent of the use of the Library in a tool for writing it). Whether that is true depends on what the Library does and what the program that uses the Library does. 1. You may copy and distribute verbatim copies of the Library's complete source code as you receive it, in any medium, provided that you conspicuously and appropriately publish on each copy an appropriate copyright notice and disclaimer of warranty; keep intact all the notices that refer to this License and to the absence of any warranty; and distribute a copy of this License along with the Library. You may charge a fee for the physical act of transferring a copy, and you may at your option offer warranty protection in exchange for a fee. 2. You may modify your copy or copies of the Library or any portion of it, thus forming a work based on the Library, and copy and distribute such modifications or work under the terms of Section 1 above, provided that you also meet all of these conditions: a) The modified work must itself be a software library. b) You must cause the files modified to carry prominent notices stating that you changed the files and the date of any change. c) You must cause the whole of the work to be licensed at no charge to all third parties under the terms of this License. d) If a facility in the modified Library refers to a function or a table of data to be supplied by an application program that uses the facility, other than as an argument passed when the facility is invoked, then you must make a good faith effort to ensure that, in the event an application does not supply such function or table, the facility still operates, and performs whatever part of its purpose remains meaningful. (For example, a function in a library to compute square roots has a purpose that is entirely well-defined independent of the application. Therefore, Subsection 2d requires that any application-supplied function or table used by this function must be optional: if the application does not supply it, the square root function must still compute square roots.) These requirements apply to the modified work as a whole. If identifiable sections of that work are not derived from the Library, and can be reasonably considered independent and separate works in themselves, then this License, and its terms, do not apply to those sections when you distribute them as separate works. But when you distribute the same sections as part of a whole which is a work based on the Library, the distribution of the whole must be on the terms of this License, whose permissions for other licensees extend to the entire whole, and thus to each and every part regardless of who wrote it. Thus, it is not the intent of this section to claim rights or contest your rights to work written entirely by you; rather, the intent is to exercise the right to control the distribution of derivative or collective works based on the Library. In addition, mere aggregation of another work not based on the Library with the Library (or with a work based on the Library) on a volume of a storage or distribution medium does not bring the other work under the scope of this License. 3. You may opt to apply the terms of the ordinary GNU General Public License instead of this License to a given copy of the Library. To do this, you must alter all the notices that refer to this License, so that they refer to the ordinary GNU General Public License, version 2, instead of to this License. (If a newer version than version 2 of the ordinary GNU General Public License has appeared, then you can specify that version instead if you wish.) Do not make any other change in these notices. Once this change is made in a given copy, it is irreversible for that copy, so the ordinary GNU General Public License applies to all subsequent copies and derivative works made from that copy. This option is useful when you wish to copy part of the code of the Library into a program that is not a library. 4. You may copy and distribute the Library (or a portion or derivative of it, under Section 2) in object code or executable form under the terms of Sections 1 and 2 above provided that you accompany it with the complete corresponding machine-readable source code, which must be distributed under the terms of Sections 1 and 2 above on a medium customarily used for software interchange. If distribution of object code is made by offering access to copy from a designated place, then offering equivalent access to copy the source code from the same place satisfies the requirement to distribute the source code, even though third parties are not compelled to copy the source along with the object code. 5. A program that contains no derivative of any portion of the Library, but is designed to work with the Library by being compiled or linked with it, is called a "work that uses the Library". Such a work, in isolation, is not a derivative work of the Library, and therefore falls outside the scope of this License. However, linking a "work that uses the Library" with the Library creates an executable that is a derivative of the Library (because it contains portions of the Library), rather than a "work that uses the library". The executable is therefore covered by this License. Section 6 states terms for distribution of such executables. When a "work that uses the Library" uses material from a header file that is part of the Library, the object code for the work may be a derivative work of the Library even though the source code is not. Whether this is true is especially significant if the work can be linked without the Library, or if the work is itself a library. The threshold for this to be true is not precisely defined by law. If such an object file uses only numerical parameters, data structure layouts and accessors, and small macros and small inline functions (ten lines or less in length), then the use of the object file is unrestricted, regardless of whether it is legally a derivative work. (Executables containing this object code plus portions of the Library will still fall under Section 6.) Otherwise, if the work is a derivative of the Library, you may distribute the object code for the work under the terms of Section 6. Any executables containing that work also fall under Section 6, whether or not they are linked directly with the Library itself. 6. As an exception to the Sections above, you may also combine or link a "work that uses the Library" with the Library to produce a work containing portions of the Library, and distribute that work under terms of your choice, provided that the terms permit modification of the work for the customer's own use and reverse engineering for debugging such modifications. You must give prominent notice with each copy of the work that the Library is used in it and that the Library and its use are covered by this License. You must supply a copy of this License. If the work during execution displays copyright notices, you must include the copyright notice for the Library among them, as well as a reference directing the user to the copy of this License. Also, you must do one of these things: a) Accompany the work with the complete corresponding machine-readable source code for the Library including whatever changes were used in the work (which must be distributed under Sections 1 and 2 above); and, if the work is an executable linked with the Library, with the complete machine-readable "work that uses the Library", as object code and/or source code, so that the user can modify the Library and then relink to produce a modified executable containing the modified Library. (It is understood that the user who changes the contents of definitions files in the Library will not necessarily be able to recompile the application to use the modified definitions.) b) Use a suitable shared library mechanism for linking with the Library. A suitable mechanism is one that (1) uses at run time a copy of the library already present on the user's computer system, rather than copying library functions into the executable, and (2) will operate properly with a modified version of the library, if the user installs one, as long as the modified version is interface-compatible with the version that the work was made with. c) Accompany the work with a written offer, valid for at least three years, to give the same user the materials specified in Subsection 6a, above, for a charge no more than the cost of performing this distribution. d) If distribution of the work is made by offering access to copy from a designated place, offer equivalent access to copy the above specified materials from the same place. e) Verify that the user has already received a copy of these materials or that you have already sent this user a copy. For an executable, the required form of the "work that uses the Library" must include any data and utility programs needed for reproducing the executable from it. However, as a special exception, the materials to be distributed need not include anything that is normally distributed (in either source or binary form) with the major components (compiler, kernel, and so on) of the operating system on which the executable runs, unless that component itself accompanies the executable. It may happen that this requirement contradicts the license restrictions of other proprietary libraries that do not normally accompany the operating system. Such a contradiction means you cannot use both them and the Library together in an executable that you distribute. 7. You may place library facilities that are a work based on the Library side-by-side in a single library together with other library facilities not covered by this License, and distribute such a combined library, provided that the separate distribution of the work based on the Library and of the other library facilities is otherwise permitted, and provided that you do these two things: a) Accompany the combined library with a copy of the same work based on the Library, uncombined with any other library facilities. This must be distributed under the terms of the Sections above. b) Give prominent notice with the combined library of the fact that part of it is a work based on the Library, and explaining where to find the accompanying uncombined form of the same work. 8. You may not copy, modify, sublicense, link with, or distribute the Library except as expressly provided under this License. Any attempt otherwise to copy, modify, sublicense, link with, or distribute the Library is void, and will automatically terminate your rights under this License. However, parties who have received copies, or rights, from you under this License will not have their licenses terminated so long as such parties remain in full compliance. 9. You are not required to accept this License, since you have not signed it. However, nothing else grants you permission to modify or distribute the Library or its derivative works. These actions are prohibited by law if you do not accept this License. Therefore, by modifying or distributing the Library (or any work based on the Library), you indicate your acceptance of this License to do so, and all its terms and conditions for copying, distributing or modifying the Library or works based on it. 10. Each time you redistribute the Library (or any work based on the Library), the recipient automatically receives a license from the original licensor to copy, distribute, link with or modify the Library subject to these terms and conditions. You may not impose any further restrictions on the recipients' exercise of the rights granted herein. You are not responsible for enforcing compliance by third parties with this License. 11. If, as a consequence of a court judgment or allegation of patent infringement or for any other reason (not limited to patent issues), conditions are imposed on you (whether by court order, agreement or otherwise) that contradict the conditions of this License, they do not excuse you from the conditions of this License. If you cannot distribute so as to satisfy simultaneously your obligations under this License and any other pertinent obligations, then as a consequence you may not distribute the Library at all. For example, if a patent license would not permit royalty-free redistribution of the Library by all those who receive copies directly or indirectly through you, then the only way you could satisfy both it and this License would be to refrain entirely from distribution of the Library. If any portion of this section is held invalid or unenforceable under any particular circumstance, the balance of the section is intended to apply, and the section as a whole is intended to apply in other circumstances. It is not the purpose of this section to induce you to infringe any patents or other property right claims or to contest validity of any such claims; this section has the sole purpose of protecting the integrity of the free software distribution system which is implemented by public license practices. Many people have made generous contributions to the wide range of software distributed through that system in reliance on consistent application of that system; it is up to the author/donor to decide if he or she is willing to distribute software through any other system and a licensee cannot impose that choice. This section is intended to make thoroughly clear what is believed to be a consequence of the rest of this License. 12. If the distribution and/or use of the Library is restricted in certain countries either by patents or by copyrighted interfaces, the original copyright holder who places the Library under this License may add an explicit geographical distribution limitation excluding those countries, so that distribution is permitted only in or among countries not thus excluded. In such case, this License incorporates the limitation as if written in the body of this License. 13. The Free Software Foundation may publish revised and/or new versions of the Lesser General Public License from time to time. Such new versions will be similar in spirit to the present version, but may differ in detail to address new problems or concerns. Each version is given a distinguishing version number. If the Library specifies a version number of this License which applies to it and "any later version", you have the option of following the terms and conditions either of that version or of any later version published by the Free Software Foundation. If the Library does not specify a license version number, you may choose any version ever published by the Free Software Foundation. 14. If you wish to incorporate parts of the Library into other free programs whose distribution conditions are incompatible with these, write to the author to ask for permission. For software which is copyrighted by the Free Software Foundation, write to the Free Software Foundation; we sometimes make exceptions for this. Our decision will be guided by the two goals of preserving the free status of all derivatives of our free software and of promoting the sharing and reuse of software generally. NO WARRANTY 15. BECAUSE THE LIBRARY IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE LIBRARY, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE LIBRARY "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE LIBRARY IS WITH YOU. SHOULD THE LIBRARY PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 16. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE LIBRARY AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE LIBRARY (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE LIBRARY TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. 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! gi-gtk-hs-0.3.9/Setup.hs0000644000000000000000000000005607346545000013143 0ustar0000000000000000import Distribution.Simple main = defaultMain gi-gtk-hs-0.3.9/cbits/0000755000000000000000000000000007346545000012612 5ustar0000000000000000gi-gtk-hs-0.3.9/cbits/Gtk2HsStore.c0000644000000000000000000007521607346545000015110 0ustar0000000000000000#include "Gtk2HsStore.h" /* #define DEBUG */ #ifdef DEBUG #define WHEN_DEBUG(a) a #else #define WHEN_DEBUG(a) #endif static void gtk2hs_store_init (Gtk2HsStore *pkg_tree); static void gtk2hs_store_class_init (Gtk2HsStoreClass *klass); static void gtk2hs_store_tree_model_init (GtkTreeModelIface *iface); static void gtk2hs_store_tree_sortable_init (GtkTreeSortableIface *iface); static void gtk2hs_store_tree_drag_source_init (GtkTreeDragSourceIface *iface); static void gtk2hs_store_tree_drag_dest_init (GtkTreeDragDestIface *iface); static void gtk2hs_store_finalize (GObject *object); static GtkTreeModelFlags gtk2hs_store_get_flags (GtkTreeModel *tree_model); static gint gtk2hs_store_get_n_columns (GtkTreeModel *tree_model); static GType gtk2hs_store_get_column_type (GtkTreeModel *tree_model, gint index); static gboolean gtk2hs_store_get_iter (GtkTreeModel *tree_model, GtkTreeIter *iter, GtkTreePath *path); static GtkTreePath *gtk2hs_store_get_path (GtkTreeModel *tree_model, GtkTreeIter *iter); static void gtk2hs_store_get_value (GtkTreeModel *tree_model, GtkTreeIter *iter, gint column, GValue *value); static gboolean gtk2hs_store_iter_next (GtkTreeModel *tree_model, GtkTreeIter *iter); static gboolean gtk2hs_store_iter_children (GtkTreeModel *tree_model, GtkTreeIter *iter, GtkTreeIter *parent); static gboolean gtk2hs_store_iter_has_child (GtkTreeModel *tree_model, GtkTreeIter *iter); static gint gtk2hs_store_iter_n_children (GtkTreeModel *tree_model, GtkTreeIter *iter); static gboolean gtk2hs_store_iter_nth_child (GtkTreeModel *tree_model, GtkTreeIter *iter, GtkTreeIter *parent, gint n); static gboolean gtk2hs_store_iter_parent (GtkTreeModel *tree_model, GtkTreeIter *iter, GtkTreeIter *child); static void gtk2hs_store_ref_node (GtkTreeModel *tree_model, GtkTreeIter *iter); static void gtk2hs_store_unref_node (GtkTreeModel *tree_model, GtkTreeIter *iter); /* The TreeSortable interface is currently not implemented and may never be. */ static gboolean gtk2hs_store_get_sort_column_id (GtkTreeSortable *sortable, gint *sort_column_id, GtkSortType *order); static void gtk2hs_store_set_sort_column_id (GtkTreeSortable *sortable, gint sort_column_id, GtkSortType order); #if GTK_MAJOR_VERSION < 3 static void gtk2hs_store_set_sort_func (GtkTreeSortable *sortable, gint sort_column_id, GtkTreeIterCompareFunc func, gpointer data, GtkDestroyNotify destroy); static void gtk2hs_store_set_default_sort_func (GtkTreeSortable *sortable, GtkTreeIterCompareFunc func, gpointer data, GtkDestroyNotify destroy); #endif static gboolean gtk2hs_store_has_default_sort_func (GtkTreeSortable *sortable); static gboolean gtk2hs_store_row_draggable (GtkTreeDragSource *drag_source, GtkTreePath *path); static gboolean gtk2hs_store_drag_data_get (GtkTreeDragSource *drag_source, GtkTreePath *path, GtkSelectionData *selection_data); static gboolean gtk2hs_store_drag_data_delete (GtkTreeDragSource *drag_source, GtkTreePath *path); static gboolean gtk2hs_store_drag_data_received (GtkTreeDragDest *drag_dest, GtkTreePath *dest_path, GtkSelectionData *selection_data); static gboolean gtk2hs_store_row_drop_possible (GtkTreeDragDest *drag_dest, GtkTreePath *dest_path, GtkSelectionData *selection_data); static GObjectClass *parent_class = NULL; /** * * gtk2hs_store_get_type: here we register our new type and its interfaces * with the type system. If you want to implement * additional interfaces like GtkTreeSortable, you * will need to do it here. * **/ GType gtk2hs_store_get_type (void) { static GType gtk2hs_store_type = 0; if (!gtk2hs_store_type) { static const GTypeInfo gtk2hs_store_info = { sizeof (Gtk2HsStoreClass), NULL, /* base_init */ NULL, /* base_finalize */ (GClassInitFunc) gtk2hs_store_class_init, NULL, /* class finalize */ NULL, /* class_data */ sizeof (Gtk2HsStore), 0, /* n_preallocs */ (GInstanceInitFunc) gtk2hs_store_init }; static const GInterfaceInfo tree_model_info = { (GInterfaceInitFunc) gtk2hs_store_tree_model_init, NULL, NULL }; #if GTK_MAJOR_VERSION < 3 /* The TreeSortable interface is currently not implemented. */ static const GInterfaceInfo tree_sortable_info = { (GInterfaceInitFunc) gtk2hs_store_tree_sortable_init, NULL, NULL }; #endif static const GInterfaceInfo tree_drag_source_info = { (GInterfaceInitFunc) gtk2hs_store_tree_drag_source_init, NULL, NULL }; static const GInterfaceInfo tree_drag_dest_info = { (GInterfaceInitFunc) gtk2hs_store_tree_drag_dest_init, NULL, NULL }; gtk2hs_store_type = g_type_register_static (G_TYPE_OBJECT, "Gtk2HsStore", >k2hs_store_info, (GTypeFlags) 0); g_type_add_interface_static (gtk2hs_store_type, GTK_TYPE_TREE_MODEL, &tree_model_info); /* The TreeSortable interface is currently not implemented. Uncomment to add it. */ /* g_type_add_interface_static (gtk2hs_store_type, GTK_TYPE_TREE_SORTABLE, &tree_sortable_info); */ g_type_add_interface_static (gtk2hs_store_type, GTK_TYPE_TREE_DRAG_SOURCE, &tree_drag_source_info); g_type_add_interface_static (gtk2hs_store_type, GTK_TYPE_TREE_DRAG_DEST, &tree_drag_dest_info); } return gtk2hs_store_type; } /** * * gtk2hs_store_class_init: more boilerplate GObject/GType stuff. * Init callback for the type system, * called once when our new class is created. * **/ static void gtk2hs_store_class_init (Gtk2HsStoreClass *class) { WHEN_DEBUG(g_debug("calling gtk2hs_store_class_init\t\t(%p)\n", class)); GObjectClass *object_class; parent_class = g_type_class_peek_parent (class); object_class = (GObjectClass*) class; object_class->finalize = gtk2hs_store_finalize; } /** * * gtk2hs_store_tree_model_init: init callback for the interface registration * in gtk2hs_store_get_type. Here we override * the GtkTreeModel interface functions that * we implement. * **/ static void gtk2hs_store_tree_model_init (GtkTreeModelIface *iface) { WHEN_DEBUG(g_debug("calling gtk2hs_store_tree_model_init\t(%p)\n", iface)); iface->get_flags = gtk2hs_store_get_flags; iface->get_n_columns = gtk2hs_store_get_n_columns; iface->get_column_type = gtk2hs_store_get_column_type; iface->get_iter = gtk2hs_store_get_iter; iface->get_path = gtk2hs_store_get_path; iface->get_value = gtk2hs_store_get_value; iface->iter_next = gtk2hs_store_iter_next; iface->iter_children = gtk2hs_store_iter_children; iface->iter_has_child = gtk2hs_store_iter_has_child; iface->iter_n_children = gtk2hs_store_iter_n_children; iface->iter_nth_child = gtk2hs_store_iter_nth_child; iface->iter_parent = gtk2hs_store_iter_parent; iface->ref_node = gtk2hs_store_ref_node; iface->unref_node = gtk2hs_store_unref_node; } #if GTK_MAJOR_VERSION < 3 /** * * gtk2hs_store_tree_sortable_init: init callback for the interface registration * in gtk2hs_store_get_type. Here we override * the GtkTreeSortable interface functions that * we implement. * **/ /* The TreeSortable interface is currently not implemented. */ static void gtk2hs_store_tree_sortable_init (GtkTreeSortableIface *iface) { WHEN_DEBUG(g_debug("calling gtk2hs_store_tree_sortable_init\t(%p)\n", iface)); iface->get_sort_column_id = gtk2hs_store_get_sort_column_id; iface->set_sort_column_id = gtk2hs_store_set_sort_column_id; iface->set_sort_func = gtk2hs_store_set_sort_func; iface->set_default_sort_func = gtk2hs_store_set_default_sort_func; iface->has_default_sort_func = gtk2hs_store_has_default_sort_func; } #endif /** * * gtk2hs_store_tree_drag_source_init: init callback for the interface registration * in gtk2hs_store_get_type. Here we override * the GtkTreeDragSource interface functions that * we implement. * **/ static void gtk2hs_store_tree_drag_source_init (GtkTreeDragSourceIface *iface) { WHEN_DEBUG(g_debug("calling gtk2hs_store_tree_drag_source_init\t(%p)\n", iface)); iface->row_draggable = gtk2hs_store_row_draggable; iface->drag_data_get = gtk2hs_store_drag_data_get; iface->drag_data_delete = gtk2hs_store_drag_data_delete; } /** * * gtk2hs_store_tree_drag_dest_init: init callback for the interface registration * in gtk2hs_store_get_type. Here we override * the GtkTreeDragDest interface functions that * we implement. * **/ static void gtk2hs_store_tree_drag_dest_init (GtkTreeDragDestIface *iface) { WHEN_DEBUG(g_debug("calling gtk2hs_store_tree_drag_dest_init\t(%p)\n", iface)); iface->drag_data_received = gtk2hs_store_drag_data_received; iface->row_drop_possible = gtk2hs_store_row_drop_possible; } /** * * gtk2hs_store_init: this is called everytime a new custom list object * instance is created (we do that in gtk2hs_store_new). * Initialise the list structure's fields here. * **/ static void gtk2hs_store_init (Gtk2HsStore *store) { WHEN_DEBUG(g_debug("calling gtk2hs_store_init\t\t(%p)\n", store)); store->stamp = g_random_int(); /* Random int to check whether an iter belongs to our model */ } /** * * gtk2hs_store_finalize: this is called just before a custom list is * destroyed. Free dynamically allocated memory here. * **/ static void gtk2hs_store_finalize (GObject *object) { WHEN_DEBUG(g_debug("calling gtk2hs_store_finalize\t(%p)\n", object)); Gtk2HsStore *store = (Gtk2HsStore *) object; g_return_if_fail(GTK2HS_IS_STORE (object)); /* free all memory used by the store */ hs_free_stable_ptr(store->impl); hs_free_stable_ptr(store->priv); /* must chain up - finalize parent */ (* parent_class->finalize) (object); } /** * * gtk2hs_store_get_flags: tells the rest of the world whether our tree model * has any special characteristics. In our case, * we have a list model (instead of a tree), and each * tree iter is valid as long as the row in question * exists, as it only contains a pointer to our struct. * **/ static GtkTreeModelFlags gtk2hs_store_get_flags (GtkTreeModel *tree_model) { WHEN_DEBUG(g_debug("calling gtk2hs_store_get_flags\t\t(%p)\n", tree_model)); Gtk2HsStore *store = (Gtk2HsStore *) tree_model; g_return_val_if_fail (GTK2HS_IS_STORE (tree_model), 0); GtkTreeModelFlags result = gtk2hs_store_get_flags_impl(store->impl); WHEN_DEBUG(g_debug("return gtk2hs_store_get_flags\t\t=%#x\n", result)); return result; } /** * * gtk2hs_store_get_n_columns: tells the rest of the world how many data * columns we export via the tree model interface * **/ static gint gtk2hs_store_get_n_columns (GtkTreeModel *tree_model) { WHEN_DEBUG(g_debug("calling gtk2hs_store_get_n_columns\t(%p)\n", tree_model)); Gtk2HsStore *store = (Gtk2HsStore *) tree_model; g_return_val_if_fail (GTK2HS_IS_STORE (tree_model), 0); gint result = gtk2hs_store_get_n_columns_impl(store->impl); WHEN_DEBUG(g_debug("return gtk2hs_store_get_n_columns\t=%d\n", result)); return result; } /** * * gtk2hs_store_get_column_type: tells the rest of the world which type of * data an exported model column contains * **/ static GType gtk2hs_store_get_column_type (GtkTreeModel *tree_model, gint index) { WHEN_DEBUG(g_debug("calling gtk2hs_store_get_column_type\t(%p, %d)\n", tree_model, index)); Gtk2HsStore *store = (Gtk2HsStore *) tree_model; g_return_val_if_fail (GTK2HS_IS_STORE (tree_model), G_TYPE_INVALID); GType result = gtk2hs_store_get_column_type_impl(store->impl, index); WHEN_DEBUG(g_debug("return gtk2hs_store_get_column_type\t=%s\n", g_type_name(result))); return result; } /** * * gtk2hs_store_get_iter: converts a tree path (physical position) into a * tree iter structure (the content of the iter * fields will only be used internally by our model). * **/ static gboolean gtk2hs_store_get_iter (GtkTreeModel *tree_model, GtkTreeIter *iter, /* out */ GtkTreePath *path /* in */) { WHEN_DEBUG( gchar *path_str = gtk_tree_path_to_string(path); g_debug("calling gtk2hs_store_get_iter\t\t(%p, %p, \"%s\")\n", tree_model, iter, path_str); g_free(path_str); ) Gtk2HsStore *store = (Gtk2HsStore *) tree_model; g_return_val_if_fail (GTK2HS_IS_STORE (tree_model), FALSE); gboolean result = gtk2hs_store_get_iter_impl(store->impl, iter, path); if (result) iter->stamp = store->stamp; WHEN_DEBUG(g_debug("return gtk2hs_store_get_iter\t\t=%s\n", result ? "TRUE" : "FALSE")); return result; } /** * * gtk2hs_store_get_path: converts a tree iter into a tree path (ie. the * physical position of that row in the list). * **/ static GtkTreePath * gtk2hs_store_get_path (GtkTreeModel *tree_model, GtkTreeIter *iter /* in */) { WHEN_DEBUG(g_debug("calling gtk2hs_store_get_path\t\t(%p, %p)\n", tree_model, iter)); Gtk2HsStore *store = (Gtk2HsStore *) tree_model; g_return_val_if_fail (GTK2HS_IS_STORE (tree_model), NULL); g_return_val_if_fail (iter->stamp == store->stamp, NULL); GtkTreePath * result = gtk2hs_store_get_path_impl(store->impl, iter); WHEN_DEBUG( gchar *result_str = gtk_tree_path_to_string(result); g_debug("return gtk2hs_store_get_path\t\t=\"%s\"\n", result_str); g_free(result_str); ) return result; } /** * * gtk2hs_store_get_value: Returns a row's exported data columns * (_get_value is what gtk_tree_model_get uses) * **/ static void gtk2hs_store_get_value (GtkTreeModel *tree_model, GtkTreeIter *iter, /* in */ gint column, GValue *value /* out */) { WHEN_DEBUG(g_debug("calling gtk2hs_store_get_value\t\t(%p, %p, %d, %p)\n", tree_model, iter, column, value)); Gtk2HsStore *store = (Gtk2HsStore *) tree_model; g_return_if_fail (GTK2HS_IS_STORE (tree_model)); g_return_if_fail (iter->stamp == store->stamp); gtk2hs_store_get_value_impl(store->impl, iter, column, value); WHEN_DEBUG( gchar *result = g_strdup_value_contents(value); g_debug("return gtk2hs_store_get_value\t\t=%s\n", result); g_free(result); ) } /** * * gtk2hs_store_iter_next: Takes an iter structure and sets it to point * to the next row. * **/ static gboolean gtk2hs_store_iter_next (GtkTreeModel *tree_model, GtkTreeIter *iter /* in+out */) { WHEN_DEBUG(g_debug("calling gtk2hs_store_iter_next\t\t(%p, %p)\n", tree_model, iter)); Gtk2HsStore *store = (Gtk2HsStore *) tree_model; g_return_val_if_fail (GTK2HS_IS_STORE (tree_model), FALSE); gboolean result = gtk2hs_store_iter_next_impl(store->impl, iter); if (result) iter->stamp = store->stamp; WHEN_DEBUG(g_debug("return gtk2hs_store_iter_next\t\t=%s\n", result ? "TRUE" : "FALSE")); return result; } /** * * gtk2hs_store_iter_children: Returns TRUE or FALSE depending on whether * the row specified by 'parent' has any children. * If it has children, then 'iter' is set to * point to the first child. Special case: if * 'parent' is NULL, then the first top-level * row should be returned if it exists. * **/ static gboolean gtk2hs_store_iter_children (GtkTreeModel *tree_model, GtkTreeIter *iter, /* out */ GtkTreeIter *parent /* in, maybe NULL */) { WHEN_DEBUG(g_debug("calling gtk2hs_store_iter_children\t(%p, %p, %p)\n", tree_model, iter, parent)); Gtk2HsStore *store = (Gtk2HsStore *) tree_model; g_return_val_if_fail (GTK2HS_IS_STORE (tree_model), FALSE); gboolean result = gtk2hs_store_iter_children_impl(store->impl, iter, parent); if (result) iter->stamp = store->stamp; WHEN_DEBUG(g_debug("return gtk2hs_store_iter_children\t=%s\n", result ? "TRUE" : "FALSE")); return result; } /** * * gtk2hs_store_iter_has_child: Returns TRUE or FALSE depending on whether * the row specified by 'iter' has any children. * **/ static gboolean gtk2hs_store_iter_has_child (GtkTreeModel *tree_model, GtkTreeIter *iter /* in */) { WHEN_DEBUG(g_debug("calling gtk2hs_store_iter_has_child\t(%p, %p)\n", tree_model, iter)); Gtk2HsStore *store = (Gtk2HsStore *) tree_model; g_return_val_if_fail (GTK2HS_IS_STORE (tree_model), FALSE); /* don't check if iter->stamp == store->stamp; see the thread culminating in * http://sourceforge.net/p/gtk2hs/mailman/message/31887332/ for details */ gboolean result = gtk2hs_store_iter_has_child_impl(store->impl, iter); WHEN_DEBUG(g_debug("return gtk2hs_store_iter_has_child\t=%s\n", result ? "TRUE" : "FALSE")); return result; } /** * * gtk2hs_store_iter_n_children: Returns the number of children the row * specified by 'iter' has. This is usually 0, * as we only have a list and thus do not have * any children to any rows. A special case is * when 'iter' is NULL, in which case we need * to return the number of top-level nodes, * ie. the number of rows in our list. * **/ static gint gtk2hs_store_iter_n_children (GtkTreeModel *tree_model, GtkTreeIter *iter /* in, maybe NULL */) { WHEN_DEBUG(g_debug("calling gtk2hs_store_iter_n_children\t(%p, %p)\n", tree_model, iter)); Gtk2HsStore *store = (Gtk2HsStore *) tree_model; g_return_val_if_fail (GTK2HS_IS_STORE (tree_model), 0); g_return_val_if_fail (iter == NULL || iter->stamp == store->stamp, 0); gboolean result = gtk2hs_store_iter_n_children_impl(store->impl, iter); WHEN_DEBUG(g_debug("return gtk2hs_store_iter_n_children\t=%d\n", result)); return result; } /** * * gtk2hs_store_iter_nth_child: If the row specified by 'parent' has any * children, set 'iter' to the n-th child and * return TRUE if it exists, otherwise FALSE. * A special case is when 'parent' is NULL, in * which case we need to set 'iter' to the n-th * row if it exists. * **/ static gboolean gtk2hs_store_iter_nth_child (GtkTreeModel *tree_model, GtkTreeIter *iter, /* out */ GtkTreeIter *parent, /* in, maybe NULL */ gint n) { WHEN_DEBUG(g_debug("calling gtk2hs_store_iter_nth_child\t(%p, %p, %p, %d)\n", tree_model, iter, parent, n)); Gtk2HsStore *store = (Gtk2HsStore *) tree_model; g_return_val_if_fail (GTK2HS_IS_STORE (tree_model), FALSE); g_return_val_if_fail (parent == NULL || parent->stamp == store->stamp, FALSE); gboolean result = gtk2hs_store_iter_nth_child_impl(store->impl, iter, parent, n); if (result) iter->stamp = store->stamp; WHEN_DEBUG(g_debug("return gtk2hs_store_iter_nth_child\t=%s\n", result ? "TRUE" : "FALSE")); return result; } /** * * gtk2hs_store_iter_parent: Point 'iter' to the parent node of 'child'. * **/ static gboolean gtk2hs_store_iter_parent (GtkTreeModel *tree_model, GtkTreeIter *iter, /* out */ GtkTreeIter *child /* in */) { WHEN_DEBUG(g_debug("calling gtk2hs_store_iter_parent\t\t(%p, %p, %p)\n", tree_model, iter, child)); Gtk2HsStore *store = (Gtk2HsStore *) tree_model; g_return_val_if_fail (GTK2HS_IS_STORE (tree_model), FALSE); g_return_val_if_fail (child != NULL, FALSE); g_return_val_if_fail (child->stamp == store->stamp, FALSE); gboolean result = gtk2hs_store_iter_parent_impl(store->impl, iter, child); if (result) iter->stamp = store->stamp; WHEN_DEBUG(g_debug("return gtk2hs_store_iter_parent\t\t=%s\n", result ? "TRUE" : "FALSE")); return result; } static void gtk2hs_store_ref_node (GtkTreeModel *tree_model, GtkTreeIter *iter) { WHEN_DEBUG(g_debug("calling gtk2hs_store_ref_node\t\t(%p, %p)\n", tree_model, iter)); Gtk2HsStore *store = (Gtk2HsStore *) tree_model; g_return_if_fail (GTK2HS_IS_STORE (tree_model)); gtk2hs_store_ref_node_impl(store->impl, iter); } static void gtk2hs_store_unref_node (GtkTreeModel *tree_model, GtkTreeIter *iter) { WHEN_DEBUG(g_debug("calling gtk2hs_store_unref_node\t\t(%p, %p)\n", tree_model, iter)); Gtk2HsStore *store = (Gtk2HsStore *) tree_model; g_return_if_fail (GTK2HS_IS_STORE (tree_model)); g_return_if_fail (iter->stamp == store->stamp); gtk2hs_store_unref_node_impl(store->impl, iter); } static gboolean gtk2hs_store_get_sort_column_id (GtkTreeSortable *sortable, gint *sort_column_id, GtkSortType *order) { WHEN_DEBUG(g_debug("calling gtk2hs_store_get_sort_column_id\t\t(%p)\n", sortable)); return 0; } static void gtk2hs_store_set_sort_column_id (GtkTreeSortable *sortable, gint sort_column_id, GtkSortType order) { WHEN_DEBUG(g_debug("calling gtk2hs_store_set_sort_column_id\t\t(%p)\n", sortable)); return; } #if GTK_MAJOR_VERSION < 3 static void gtk2hs_store_set_sort_func (GtkTreeSortable *sortable, gint sort_column_id, GtkTreeIterCompareFunc func, gpointer data, GtkDestroyNotify destroy) { WHEN_DEBUG(g_debug("calling gtk2hs_store_set_sort_func\t\t(%p)\n", sortable)); return; } static void gtk2hs_store_set_default_sort_func (GtkTreeSortable *sortable, GtkTreeIterCompareFunc func, gpointer data, GtkDestroyNotify destroy) { WHEN_DEBUG(g_debug("calling gtk2hs_store_set_default_sort_func\t\t(%p)\n", sortable)); return; } #endif static gboolean gtk2hs_store_has_default_sort_func (GtkTreeSortable *sortable) { WHEN_DEBUG(g_debug("calling gtk2hs_store_has_default_sort_func\t\t(%p)\n", sortable)); return 0; } static gboolean gtk2hs_store_row_draggable (GtkTreeDragSource *drag_source, GtkTreePath *path) { WHEN_DEBUG( gchar *path_str = gtk_tree_path_to_string(path); g_debug("calling gtk2hs_store_row_draggable\t\t(%p, \"%s\")\n", drag_source, path_str); g_free(path_str); ) Gtk2HsStore *store = (Gtk2HsStore *) drag_source; g_return_val_if_fail (GTK2HS_IS_STORE (drag_source), FALSE); gboolean result = gtk2hs_store_row_draggable_impl(drag_source, store->impl, path); WHEN_DEBUG(g_debug("return gtk2hs_store_row_draggable\t\t=%s\n", result ? "TRUE" : "FALSE")); return result; } static gboolean gtk2hs_store_drag_data_get (GtkTreeDragSource *drag_source, GtkTreePath *path, GtkSelectionData *selection_data) { WHEN_DEBUG( gchar *path_str = gtk_tree_path_to_string(path); g_debug("calling gtk2hs_store_drag_data_get\t\t(%p, \"%s\", %p)\n", drag_source, path_str, selection_data); g_free(path_str); ) Gtk2HsStore *store = (Gtk2HsStore *) drag_source; g_return_val_if_fail (GTK2HS_IS_STORE (drag_source), FALSE); g_return_val_if_fail (selection_data!=NULL, FALSE); gboolean result = gtk2hs_store_drag_data_get_impl(drag_source, store->impl, path, selection_data); WHEN_DEBUG(g_debug("return gtk2hs_store_drag_data_get\t\t=%s\n", result ? "TRUE" : "FALSE")); return result; } static gboolean gtk2hs_store_drag_data_delete (GtkTreeDragSource *drag_source, GtkTreePath *path) { WHEN_DEBUG( gchar *path_str = gtk_tree_path_to_string(path); g_debug("calling gtk2hs_store_drag_data_delete\t\t(%p, \"%s\")\n", drag_source, path_str); g_free(path_str); ) Gtk2HsStore *store = (Gtk2HsStore *) drag_source; g_return_val_if_fail (GTK2HS_IS_STORE (drag_source), FALSE); gboolean result = gtk2hs_store_drag_data_delete_impl(drag_source, store->impl, path); WHEN_DEBUG(g_debug("return gtk2hs_store_drag_data_delete\t\t=%s\n", result ? "TRUE" : "FALSE")); return result; } static gboolean gtk2hs_store_drag_data_received (GtkTreeDragDest *drag_dest, GtkTreePath *dest_path, GtkSelectionData *selection_data) { WHEN_DEBUG( gchar *path_str = gtk_tree_path_to_string(dest_path); g_debug("calling gtk2hs_store_drag_data_received\t\t(%p, \"%s\", %p)\n", drag_dest, path_str, selection_data); g_free(path_str); ) Gtk2HsStore *store = (Gtk2HsStore *) drag_dest; g_return_val_if_fail (GTK2HS_IS_STORE (drag_dest), FALSE); g_return_val_if_fail (selection_data!=NULL, FALSE); gboolean result = gtk2hs_store_drag_data_received_impl(drag_dest, store->impl, dest_path, selection_data); WHEN_DEBUG(g_debug("return gtk2hs_store_drag_data_received\t\t=%s\n", result ? "TRUE" : "FALSE")); return result; } static gboolean gtk2hs_store_row_drop_possible (GtkTreeDragDest *drag_dest, GtkTreePath *dest_path, GtkSelectionData *selection_data) { WHEN_DEBUG( gchar *path_str = gtk_tree_path_to_string(dest_path); g_debug("calling gtk2hs_store_row_drop_possible\t\t(%p, \"%s\", %p)\n", drag_dest, path_str, selection_data); g_free(path_str); ) Gtk2HsStore *store = (Gtk2HsStore *) drag_dest; g_return_val_if_fail (GTK2HS_IS_STORE (drag_dest), FALSE); g_return_val_if_fail (selection_data!=NULL, FALSE); gboolean result = gtk2hs_store_row_drop_possible_impl(drag_dest, store->impl, dest_path, selection_data); WHEN_DEBUG(g_debug("return gtk2hs_store_row_drop_possible\t\t=%s\n", result ? "TRUE" : "FALSE")); return result; } /** * * gtk2hs_store_new: Create a new custom tree model which delegates to a * Haskell implementation. * **/ Gtk2HsStore * gtk2hs_store_new (HsStablePtr impl, HsStablePtr priv) { WHEN_DEBUG(g_debug("calling gtk2hs_store_new\t\t(%p)\n", impl)); Gtk2HsStore *newstore = (Gtk2HsStore*) g_object_new (GTK2HS_TYPE_STORE, NULL); newstore->impl = impl; newstore->priv = priv; WHEN_DEBUG(g_debug("return gtk2hs_store_new\t\t=%p\n", newstore)); return newstore; } HsStablePtr gtk2hs_store_get_impl (Gtk2HsStore *store) { g_return_val_if_fail(GTK2HS_IS_STORE(store), NULL); return store->impl; } HsStablePtr gtk2hs_store_get_priv (Gtk2HsStore *store) { g_return_val_if_fail(GTK2HS_IS_STORE(store), NULL); return store->priv; } gint gtk2hs_store_get_stamp (Gtk2HsStore *store) { g_return_val_if_fail(GTK2HS_IS_STORE(store), 0); return store->stamp; } void gtk2hs_store_increment_stamp (Gtk2HsStore *store) { g_return_if_fail(GTK2HS_IS_STORE(store)); do { store->stamp++; } while (store->stamp == 0); } gi-gtk-hs-0.3.9/cbits/Gtk2HsStore.h0000755000000000000000000000311007346545000015100 0ustar0000000000000000#ifndef __GTK2HS_STORE_H__ #define __GTK2HS_STORE_H__ #include #include "Data/GI/Gtk/ModelView/CustomStore_stub.h" G_BEGIN_DECLS #define GTK2HS_TYPE_STORE (gtk2hs_store_get_type ()) #define GTK2HS_STORE(obj) (G_TYPE_CHECK_INSTANCE_CAST ((obj), GTK2HS_TYPE_STORE, Gtk2HsStore)) #define GTK2HS_STORE_CLASS(klass) (G_TYPE_CHECK_CLASS_CAST ((klass), GTK2HS_TYPE_STORE, Gtk2HsStoreClass)) #define GTK2HS_IS_STORE(obj) (G_TYPE_CHECK_INSTANCE_TYPE ((obj), GTK2HS_TYPE_STORE)) #define GTK2HS_IS_STORE_CLASS(klass) (G_TYPE_CHECK_CLASS_TYPE ((klass), GTK2HS_TYPE_STORE)) #define GTK2HS_STORE_GET_CLASS(obj) (G_TYPE_INSTANCE_GET_CLASS ((obj), GTK2HS_TYPE_STORE, Gtk2HsStoreClass)) typedef struct _Gtk2HsStore Gtk2HsStore; typedef struct _Gtk2HsStoreClass Gtk2HsStoreClass; struct _Gtk2HsStore { GObject parent; /*< private >*/ HsStablePtr impl; /* a StablePtr CustomStore */ HsStablePtr priv; /* a StablePtr to private data */ gint stamp; /* Random integer to check whether an iter belongs to our model */ }; struct _Gtk2HsStoreClass { GObjectClass parent_class; }; GType gtk2hs_store_get_type (void) G_GNUC_CONST; Gtk2HsStore *gtk2hs_store_new (HsStablePtr, HsStablePtr); HsStablePtr gtk2hs_store_get_impl (Gtk2HsStore *); HsStablePtr gtk2hs_store_get_priv (Gtk2HsStore *); gint gtk2hs_store_get_stamp (Gtk2HsStore *); void gtk2hs_store_increment_stamp (Gtk2HsStore *); G_END_DECLS #endif /* __GTK2HS_STORE_H__ */ gi-gtk-hs-0.3.9/cbits/quartzfix.c0000644000000000000000000000061407346545000015014 0ustar0000000000000000#include void gtk_drag_set_icon_gicon (void *context, void *icon, int hot_x, int hot_y) { printf("gtk_drag_set_icon_gicon not implemented"); } void gtk_drag_source_set_icon_gicon (void *widget, void *icon) { printf("gtk_drag_source_set_icon_gicon not implemented"); } gi-gtk-hs-0.3.9/gi-gtk-hs.cabal0000644000000000000000000000372507346545000014273 0ustar0000000000000000name: gi-gtk-hs version: 0.3.9 synopsis: A wrapper for gi-gtk, adding a few more idiomatic API parts on top description: A wrapper for gi-gtk, adding a few more idiomatic API parts on top homepage: https://github.com/haskell-gi/haskell-gi license: LGPL-2.1 license-file: LICENSE author: Jonas Platte, Duncan Coutts, Axel Simon, Hamish Mackenzie, Iñaki García Etxebarria maintainer: mail@jonasplatte.de category: Graphics build-type: Simple cabal-version: >=1.10 extra-source-files: cbits/Gtk2HsStore.h library exposed-modules: Data.GI.Gtk, Data.GI.Gtk.BuildFn Data.GI.Gtk.Threading Data.GI.Gtk.ModelView.Types Data.GI.Gtk.ModelView.CellLayout Data.GI.Gtk.ModelView.CustomStore Data.GI.Gtk.ModelView.SeqStore Data.GI.Gtk.ModelView.ForestStore Data.GI.Gtk.ModelView.TreeModel Data.GI.Gtk.ComboBox build-depends: base >= 4.9 && <5, base-compat >=0.9.0 && <0.12, mtl >= 2.1 && <2.3, transformers >=0.3.0.0 && <0.6, containers >=0.5.5.1 && <0.7, text >=1.2 && <1.3, haskell-gi-base >=0.24.0 && <0.25, gi-glib >=2.0.6 && <2.1, gi-gobject >=2.0.6 && <2.1, gi-gdk >= 3.0.6 && <3.1, gi-gtk >= 3.0.26 && <3.1, gi-gdkpixbuf >=2.0.6 && <2.1 hs-source-dirs: src default-language: Haskell2010 c-sources: cbits/Gtk2HsStore.c if os(osx) c-sources: cbits/quartzfix.c include-dirs: cbits gi-gtk-hs-0.3.9/src/Data/GI/0000755000000000000000000000000007346545000013445 5ustar0000000000000000gi-gtk-hs-0.3.9/src/Data/GI/Gtk.hs0000644000000000000000000000130007346545000014520 0ustar0000000000000000module Data.GI.Gtk ( module GI.Gtk , module Data.GI.Gtk.ModelView.Types , module Data.GI.Gtk.ModelView.CellLayout , module Data.GI.Gtk.ModelView.CustomStore , module Data.GI.Gtk.ModelView.SeqStore , module Data.GI.Gtk.ModelView.ForestStore , module Data.GI.Gtk.ModelView.TreeModel , module Data.GI.Gtk.ComboBox ) where import GI.Gtk hiding (treeModelGetValue, treeModelGetIter) import Data.GI.Gtk.BuildFn import Data.GI.Gtk.ModelView.Types import Data.GI.Gtk.ModelView.CellLayout import Data.GI.Gtk.ModelView.CustomStore import Data.GI.Gtk.ModelView.SeqStore import Data.GI.Gtk.ModelView.ForestStore import Data.GI.Gtk.ModelView.TreeModel import Data.GI.Gtk.ComboBox gi-gtk-hs-0.3.9/src/Data/GI/Gtk/0000755000000000000000000000000007346545000014172 5ustar0000000000000000gi-gtk-hs-0.3.9/src/Data/GI/Gtk/BuildFn.hs0000644000000000000000000000326107346545000016053 0ustar0000000000000000{-# LANGUAGE CPP #-} {-| A module aimed at making working with GtkBuilder easier. It's meant to be used like this (requires OverloadedStrings): > buildUI :: BuildFn () > buildUI = do > mainWin <- buildMainWin > buildAboutDialog > > widgetShowAll mainWin > > buildMainWin :: BuildFn ApplicationWindow > buildMainWin = do > buildHeaderBar > buildMenuBar > buildMainArea > > mainWin <- getObject' ApplicationWindow "mainWin" > on mainWin Destroy mainQuit > return mainWin > > buildAboutDialog :: BuildFn AboutDialog > ... > > buildHeaderBar :: BuildFn HeaderBar > ... > > buildMenuBar :: BuildFn MenuBar > ... > > buildMainArea :: BuildFn Grid > ... -} module Data.GI.Gtk.BuildFn ( BuildFn , buildWithBuilder , getObject ) where import Prelude () import Prelude.Compat import Control.Monad.Reader (ReaderT, runReaderT, ask, MonadIO, liftIO) import Data.GI.Base (GObject, castTo) #if !MIN_VERSION_haskell_gi_base(0,20,1) import Data.GI.Base.BasicTypes (nullToNothing) #endif import Data.Maybe (fromJust) import qualified Data.Text as T import Foreign.ForeignPtr (ForeignPtr) import GI.Gtk hiding (main) type BuildFn a = ReaderT Builder IO a buildWithBuilder :: MonadIO m => BuildFn a -> Builder -> m a buildWithBuilder fn builder = liftIO $ runReaderT fn builder getObject :: GObject a => (ManagedPtr a -> a) -> T.Text -> BuildFn a getObject ctor name = do builder <- ask #if MIN_VERSION_haskell_gi_base(0,20,1) Just obj <- builderGetObject builder name #else Just obj <- nullToNothing $ builderGetObject builder name #endif liftIO $ fromJust <$> castTo ctor obj gi-gtk-hs-0.3.9/src/Data/GI/Gtk/ComboBox.hs0000644000000000000000000002242607346545000016244 0ustar0000000000000000-- -*-haskell-*- -- GIMP Toolkit (GTK) Widget ComboBox -- -- Author : Duncan Coutts -- -- Created: 25 April 2004 -- -- Copyright (C) 2004-2016 Duncan Coutts, Axel Simon, Hamish Mackenzie -- -- 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. {-# LANGUAGE MonoLocalBinds #-} -- | -- Stability : provisional -- Portability : portable (depends on GHC) -- -- A widget used to choose from a list of items. -- -- * Module available since Gtk+ version 2.4 -- module Data.GI.Gtk.ComboBox ( -- * Detail -- -- | A 'ComboBox' is a widget that allows the user to choose from a list of -- valid choices. The 'ComboBox' displays the selected choice. When activated, -- the 'ComboBox' displays a popup which allows the user to make a new choice. -- The style in which the selected value is displayed, and the style of the -- popup is determined by the current theme. It may be similar to a -- 'OptionMenu', or similar to a Windows-style combo box. -- -- Unlike its predecessors 'Combo' and 'OptionMenu', the 'ComboBox' uses the -- model-view pattern; the list of valid choices is specified in the form of a -- tree model, and the display of the choices can be adapted to the data in -- the model by using cell renderers, as you would in a tree view. This is -- possible since 'ComboBox' implements the 'CellLayout' interface. The tree -- model holding the valid choices is not restricted to a flat list, it can be -- a real tree, and the popup will reflect the tree structure. -- -- In addition to the general model-view API, 'ComboBox' offers the function -- 'comboBoxNewText' which creates a text-only combo box. -- * Class Hierarchy -- -- | -- @ -- | 'GObject' -- | +----'Object' -- | +----'Widget' -- | +----'Container' -- | +----'Bin' -- | +----ComboBox -- | +----'ComboBoxEntry' -- @ module GI.Gtk.Objects.ComboBox, -- ** Simple Text API comboBoxNewText, comboBoxSetModelText, comboBoxGetModelText, comboBoxAppendText, comboBoxInsertText, comboBoxPrependText, comboBoxRemoveText, comboBoxGetActiveText, ) where import Prelude () import Prelude.Compat import Control.Monad (liftM) import Control.Monad.IO.Class (MonadIO(..)) import Foreign.Ptr (FunPtr, Ptr, nullPtr) import Foreign.StablePtr (newStablePtr, castStablePtrToPtr, deRefStablePtr, castPtrToStablePtr) import Data.Text (Text) import Data.Word (Word32) import Data.Int (Int32) import Data.GI.Base.BasicTypes (GObject) import Data.GI.Base.ManagedPtr (unsafeManagedPtrCastPtr, touchManagedPtr, unsafeCastTo) import Data.GI.Gtk.ModelView.Types (comboQuark) import Data.GI.Gtk.ModelView.TreeModel (makeColumnIdString) import Data.GI.Gtk.ModelView.CustomStore (customStoreSetColumn, customStoreGetRow) import Data.GI.Gtk.ModelView.SeqStore ( SeqStore(..), seqStoreNew, seqStoreInsert, seqStorePrepend, seqStoreAppend, seqStoreRemove, seqStoreSafeGetValue ) import GI.Gtk.Objects.ComboBox import Data.GI.Gtk.ModelView.CellLayout (CellLayout(..), cellLayoutClear, cellLayoutPackStart, cellLayoutSetDataFunction, cellLayoutGetCells) import GI.Gtk.Objects.CellRendererText (CellRendererText(..), cellRendererTextNew, setCellRendererTextText) import GI.GObject.Objects.Object (Object, toObject) type GQuark = Word32 -- | The address of a function freeing a 'StablePtr'. See 'destroyFunPtr'. foreign import ccall unsafe "&hs_free_stable_ptr" destroyStablePtr :: FunPtr(Ptr () -> IO ()) foreign import ccall "g_object_set_qdata" g_object_set_qdata :: Ptr Object -> GQuark -> Ptr () -> IO () foreign import ccall "g_object_set_qdata_full" g_object_set_qdata_full :: Ptr Object -> GQuark -> Ptr () -> FunPtr(Ptr () -> IO ()) -> IO () -- | Set the value of an association. -- objectSetAttribute :: (MonadIO m, GObject o) => o -> GQuark -> Maybe a -> m () objectSetAttribute obj attr Nothing = liftIO $ do obj' <- unsafeManagedPtrCastPtr obj g_object_set_qdata obj' (fromIntegral attr) nullPtr touchManagedPtr obj objectSetAttribute obj attr (Just val) = liftIO $ do sPtr <- newStablePtr val obj' <- unsafeManagedPtrCastPtr obj g_object_set_qdata_full obj' attr (castStablePtrToPtr sPtr) destroyStablePtr touchManagedPtr obj foreign import ccall "g_object_get_qdata" g_object_get_qdata :: Ptr Object -> GQuark -> IO (Ptr ()) -- | Get the value of an association. -- -- * Note that this function may crash the Haskell run-time since the -- returned type can be forced to be anything. See 'objectCreateAttribute' -- for a safe wrapper around this funciton. -- objectGetAttributeUnsafe :: (MonadIO m, GObject o) => o -> GQuark -> m (Maybe a) objectGetAttributeUnsafe obj attr = liftIO $ do obj' <- unsafeManagedPtrCastPtr obj sPtr <- g_object_get_qdata obj' attr touchManagedPtr obj if sPtr==nullPtr then return Nothing else liftM Just $! deRefStablePtr (castPtrToStablePtr sPtr) -------------------- -- Constructors -- | Convenience function which constructs a new text combo box that is a -- 'ComboBox' just displaying strings. This function internally calls -- 'comboBoxSetModelText' after creating a new combo box. -- comboBoxNewText :: MonadIO m => m ComboBox comboBoxNewText = do combo <- comboBoxNew comboBoxSetModelText combo return combo -------------------- -- Methods -- the text API -- | Create a combo box that holds strings. -- -- This function stores a 'Data.GI.Gtk.ModelView.SeqStore' with the -- widget and sets the model to the list store. The widget can contain only -- strings. The model can be retrieved with 'comboBoxGetModel'. The list -- store can be retrieved with 'comboBoxGetModelText'. -- Any exisiting model or renderers are removed before setting the new text -- model. -- Note that the functions 'comboBoxAppendText', 'comboBoxInsertText', -- 'comboBoxPrependText', 'comboBoxRemoveText' and 'comboBoxGetActiveText' -- can be called on a combo box only once 'comboBoxSetModelText' is called. -- comboBoxSetModelText :: (MonadIO m, IsComboBox self) => self -> m (SeqStore Text) comboBoxSetModelText combo = liftIO $ do layout <- unsafeCastTo CellLayout combo cellLayoutClear layout store <- seqStoreNew ([] :: [Text]) comboBoxSetModel combo (Just store) let colId = makeColumnIdString 0 customStoreSetColumn store colId id comboBoxSetEntryTextColumn combo 0 ren <- cellRendererTextNew cellLayoutPackStart layout ren True cellLayoutSetDataFunction layout ren store (setCellRendererTextText ren) objectSetAttribute combo comboQuark (Just store) return store -- | Retrieve the model that was created with 'comboBoxSetModelText'. -- comboBoxGetModelText :: (MonadIO m, IsComboBox self) => self -> m (SeqStore Text) comboBoxGetModelText self = do maybeStore <- objectGetAttributeUnsafe self comboQuark case maybeStore of Just store -> return store Nothing -> error "Could not get required attribute" -- | Appends @string@ to the list of strings stored in @comboBox@. Note that -- you can only use this function with combo boxes constructed with -- 'comboBoxNewText'. Returns the index of the appended text. -- comboBoxAppendText :: (MonadIO m, IsComboBox self) => self -> Text -> m Int32 comboBoxAppendText self text = do store <- comboBoxGetModelText self seqStoreAppend store text -- %hash c:41de d:8ab0 -- | Inserts @string@ at @position@ in the list of strings stored in -- @comboBox@. Note that you can only use this function with combo boxes -- constructed with 'comboBoxNewText'. -- comboBoxInsertText :: (MonadIO m, IsComboBox self) => self -> Int32 -- ^ @position@ - An index to insert @text@. -> Text -- ^ @text@ - A string. -> m () comboBoxInsertText self position text = do store <- comboBoxGetModelText self seqStoreInsert store position text -- | Prepends @string@ to the list of strings stored in @comboBox@. Note that -- you can only use this function with combo boxes constructed with -- 'comboBoxNewText'. -- comboBoxPrependText :: (Applicative m, MonadIO m, IsComboBox self) => self -> Text -> m () comboBoxPrependText self text = do store <- comboBoxGetModelText self seqStorePrepend store text -- | Removes the string at @position@ from @comboBox@. Note that you can only -- use this function with combo boxes constructed with 'comboBoxNewText'. -- comboBoxRemoveText :: (MonadIO m, IsComboBox self) => self -> Int32 -- ^ @position@ - Index of the item to remove. -> m () comboBoxRemoveText self position = do store <- comboBoxGetModelText self seqStoreRemove store position -- | Returns the currently active string in @comboBox@ or @Nothing@ if none is -- selected. Note that you can only use this function with combo boxes -- constructed with 'comboBoxNewText'. -- comboBoxGetActiveText :: (MonadIO m, IsComboBox self) => self -> m (Maybe Text) comboBoxGetActiveText self = do activeId <- comboBoxGetActive self if activeId < 0 then return Nothing else do seqStore <- comboBoxGetModelText self seqStoreSafeGetValue seqStore (fromIntegral activeId) gi-gtk-hs-0.3.9/src/Data/GI/Gtk/ModelView/0000755000000000000000000000000007346545000016065 5ustar0000000000000000gi-gtk-hs-0.3.9/src/Data/GI/Gtk/ModelView/CellLayout.hs0000644000000000000000000002264707346545000020511 0ustar0000000000000000{-# LANGUAGE LambdaCase #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE MonoLocalBinds #-} -- -*-haskell-*- -- GIMP Toolkit (GTK) Interface CellLayout -- -- Author : Axel Simon -- -- Created: 23 January 2006 -- -- Copyright (C) 2016-2016 Axel Simon, Hamish Mackenzie -- -- 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. -- -- | -- Stability : provisional -- Portability : portable (depends on GHC) -- -- An interface for packing cells -- -- * Module available since Gtk+ version 2.4 -- module Data.GI.Gtk.ModelView.CellLayout ( -- * Detail -- -- | 'CellLayout' is an interface which is implemented by all objects which -- provide a 'TreeViewColumn' API for packing cells, setting attributes and data funcs. -- * Class Hierarchy -- | -- @ -- | Interface CellLayout -- | +----'TreeViewColumn' -- | +----'CellView' -- | +----'IconView' -- | +----'EntryCompletion' -- | +----'ComboBox' -- | +----'ComboBoxEntry' -- @ module GI.Gtk.Interfaces.CellLayout -- , cellLayoutAddColumnAttribute , cellLayoutSetAttributes , cellLayoutSetDataFunction , cellLayoutSetDataFunc' , convertIterFromParentToChildModel ) where import Control.Monad.IO.Class (MonadIO(..)) import Foreign.Ptr (castPtr) import Foreign.Storable (peek) import Data.GI.Base.Attributes (AttrOp, AttrOpTag(..), set) import Data.GI.Base.ManagedPtr (castTo, withManagedPtr) import GI.Gtk.Interfaces.CellLayout import GI.Gtk.Objects.TreeModelFilter (TreeModelFilter(..), getTreeModelFilterChildModel, treeModelFilterConvertIterToChildIter) import GI.Gtk.Objects.TreeModelSort (TreeModelSort(..), getTreeModelSortModel, treeModelSortConvertIterToChildIter) import GI.Gtk.Structs.TreeIter (getTreeIterStamp, getTreeIterUserData3, getTreeIterUserData2, getTreeIterUserData, TreeIter(..)) import GI.Gtk.Objects.CellRenderer (IsCellRenderer, CellRenderer(..), toCellRenderer) import Data.GI.Gtk.ModelView.Types import Data.GI.Gtk.ModelView.TreeModel import Data.GI.Gtk.ModelView.CustomStore (customStoreGetRow) import Data.GI.Base (get) import Data.GI.Base.BasicTypes (ManagedPtr(..)) -------------------- -- Methods -- | Adds an attribute mapping to the renderer @cell@. The @column@ is -- the 'ColumnId' of the model to get a value from, and the @attribute@ is the -- parameter on @cell@ to be set from the value. So for example if column 2 of -- the model contains strings, you could have the \"text\" attribute of a -- 'CellRendererText' get its values from column 2. -- -- cellLayoutAddColumnAttribute :: (MonadIO m, IsCellLayout self, IsCellRenderer cell) => self -- -> cell -- ^ @cell@ - A 'CellRenderer'. -- -> ReadWriteAttr cell a v -- ^ @attribute@ - An attribute of a renderer. -- -> ColumnId row v -- ^ @column@ - The virtual column of the model from which to -- -- retrieve the attribute. -- -> m () -- cellLayoutAddColumnAttribute self cell attr column = -- cellLayoutAddAttribute self cell (T.pack $ show attr) (columnIdToNumber column) -- | Specify how a row of the @model@ defines the -- attributes of the 'CellRenderer' @cell@. This is a convenience wrapper -- around 'cellLayoutSetAttributeFunc' in that it sets the cells of the @cell@ -- with the data retrieved from the model. -- -- * Note on using 'Data.GI.Gtk.ModelView.TreeModelSort.TreeModelSort' and -- 'Data.GI.Gtk.ModelView.TreeModelFilter.TreeModelFilter': These two models -- wrap another model, the so-called child model, instead of storing their own -- data. This raises the problem that the data of cell renderers must be set -- using the child model, while the 'TreeIter's that the view works with refer to -- the model that encapsulates the child model. For convenience, this function -- transparently translates an iterator to the child model before extracting the -- data using e.g. 'Data.GI.Gtk.TreeModel.TreeModelSort.treeModelSortConvertIterToChildIter'. -- Hence, it is possible to install the encapsulating model in the view and to -- pass the child model to this function. -- cellLayoutSetAttributes :: (MonadIO m, IsCellLayout self, IsCellRenderer cell, IsTreeModel (model row), IsTypedTreeModel model) => self -> cell -- ^ @cell@ - A 'CellRenderer'. -> model row -- ^ @model@ - A model containing rows of type @row@. -> (row -> [AttrOp cell 'AttrSet]) -- ^ Function to set attributes on the cell renderer. -> m () cellLayoutSetAttributes self cell model attributes = cellLayoutSetDataFunc' self cell model $ \iter -> do row <- customStoreGetRow model iter set cell (attributes row) -- | Like 'cellLayoutSetAttributes', but allows any IO action to be used cellLayoutSetDataFunction :: (MonadIO m, IsCellLayout self, IsCellRenderer cell, IsTreeModel (model row), IsTypedTreeModel model) => self -> cell -- ^ @cell@ - A 'CellRenderer'. -> model row -- ^ @model@ - A model containing rows of type @row@. -> (row -> IO ()) -- ^ Function to set data on the cell renderer. -> m () cellLayoutSetDataFunction self cell model callback = cellLayoutSetDataFunc' self cell model $ \iter -> do row <- customStoreGetRow model iter callback row -- | Install a function that looks up a row in the model and sets the -- attributes of the 'CellRenderer' @cell@ using the row's content. -- cellLayoutSetDataFunc' :: (MonadIO m, IsCellLayout self, IsCellRenderer cell, IsTreeModel model) => self -> cell -- ^ @cell@ - A 'CellRenderer'. -> model -- ^ @model@ - A model from which to draw data. -> (TreeIter -> IO ()) -- ^ Function to set attributes on the cell renderer. -> m () cellLayoutSetDataFunc' self cell model func = liftIO $ do cellLayoutSetCellDataFunc self cell . Just $ \_ (CellRenderer cellPtr') model' iter -> do castModel <- toTreeModel model iter <- convertIterFromParentToChildModel iter model' castModel CellRenderer cellPtr <- toCellRenderer cell if managedForeignPtr cellPtr /= managedForeignPtr cellPtr' then error ("cellLayoutSetAttributeFunc: attempt to set attributes of "++ "a different CellRenderer.") else func iter -- Given a 'TreeModelFilter' or a 'TreeModelSort' and a 'TreeIter', get the -- child model of these models and convert the iter to an iter of the child -- model. This is an ugly internal function that is needed for some widgets -- which pass iterators to the callback function of set_cell_data_func that -- refer to some internal TreeModelFilter models that they create around the -- user model. This is a bug but since C programs mostly use the columns -- rather than the cell_layout way to extract attributes, this bug does not -- show up in many programs. Reported in the case of EntryCompletion as bug -- \#551202. -- convertIterFromParentToChildModel :: TreeIter -- ^ the iterator -> TreeModel -- ^ the model that we got from the all back -> TreeModel -- ^ the model that we actually want -> IO TreeIter convertIterFromParentToChildModel iter parentModel@(TreeModel parentModelPtr) childModel = let (TreeModel modelPtr) = childModel in if managedForeignPtr modelPtr == managedForeignPtr parentModelPtr then return iter else castTo TreeModelFilter parentModel >>= \case Just tmFilter -> do childIter <- treeModelFilterConvertIterToChildIter tmFilter iter Just child@(TreeModel childPtr) <- getTreeModelFilterChildModel tmFilter if managedForeignPtr childPtr == managedForeignPtr modelPtr then return childIter else convertIterFromParentToChildModel childIter child childModel Nothing -> do castTo TreeModelSort parentModel >>= \case Just tmSort -> do childIter <- treeModelSortConvertIterToChildIter tmSort iter child@(TreeModel childPtr) <- getTreeModelSortModel tmSort if managedForeignPtr childPtr == managedForeignPtr modelPtr then return childIter else convertIterFromParentToChildModel childIter child childModel Nothing -> do stamp <- getTreeIterStamp iter ud1 <- getTreeIterUserData iter ud2 <- getTreeIterUserData2 iter ud3 <- getTreeIterUserData3 iter error ("CellLayout: don't know how to convert iter "++show (stamp, ud1, ud2, ud3)++ " from model "++show (managedForeignPtr parentModelPtr)++" to model "++ show (managedForeignPtr modelPtr)++". Is it possible that you are setting the "++ "attributes of a CellRenderer using a different model than "++ "that which was set in the view?") gi-gtk-hs-0.3.9/src/Data/GI/Gtk/ModelView/CustomStore.hs0000644000000000000000000007113507346545000020717 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE TypeApplications #-} -- -*-haskell-*- -- GIMP Toolkit (GTK) CustomStore TreeModel -- -- Author : Duncan Coutts, Axel Simon -- -- Created: 19 Sep 2005 -- -- Copyright (C) 2005-2016 Duncan Coutts, Axel Simon, Hamish Mackenzie -- -- 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. -- #prune -- | -- Stability : provisional -- Portability : portable (depends on GHC) -- -- Allows a custom data structure to be used with the 'TreeView' and other -- widgets that follow the model-view-controller paradigm. The two models -- 'Data.GI.Gtk.ModelView.ListStore.ListStore' and -- 'Data.GI.Gtk.ModelView.TreeStore.TreeStore' are based on the -- 'CustomStore'. Even if no application-specific tree model -- should be implemented, this module is relevant in that it provides the -- functions 'customStoreSetColumn' and -- 'customStoreGetRow' functions. -- module Data.GI.Gtk.ModelView.CustomStore ( -- * The definition of a row-based store. CustomStore(..), TreeModelFlags(..), TreeModelIface(..), DragSourceIface(..), DragDestIface(..), customStoreNew, customStoreGetRow, customStoreSetColumn, customStoreGetPrivate, customStoreGetStamp, customStoreInvalidateIters, -- for backwards compatability, not documented ) where import Prelude () import Prelude.Compat import Control.Monad ((>=>), liftM, void) import Control.Monad.IO.Class (MonadIO(..)) import Data.IORef (IORef, newIORef, readIORef, writeIORef) import Data.Maybe (fromMaybe) import Data.Int (Int32(..)) import Foreign.Ptr (Ptr, nullPtr) import Foreign.C.Types (CInt(..), CULong(..)) import Foreign.C.String (CString(..)) import Foreign.ForeignPtr (ForeignPtr, withForeignPtr, newForeignPtr_) import Foreign.StablePtr (deRefStablePtr, newStablePtr, StablePtr(..)) import Foreign.Marshal (fromBool) import Foreign.Storable (peek, poke, peekByteOff) import System.IO.Unsafe (unsafePerformIO) import Data.GI.Base.BasicTypes (ManagedPtr(..), GObject, TypedObject(..), GType, CGType(..), gtypeToCGType) import Data.GI.Base.GType (gtypeInt, gtypeBoolean, gtypeString, gtypeInvalid) import Data.GI.Base.BasicConversions (gflagsToWord, withTextCString) import Data.GI.Base.ManagedPtr (newObject, withManagedPtr, newManagedPtr_) import Data.GI.Base.GValue (GValue(..)) import Data.GI.Base.Overloading (HasParentTypes, ParentTypes) import GI.GObject (Object) import GI.GdkPixbuf.Objects (Pixbuf(..)) import GI.Gtk.Flags (TreeModelFlags(..)) import GI.Gtk.Interfaces.TreeModel (TreeModel(..), IsTreeModel(..)) import GI.Gtk.Structs (SelectionData(..), TreePath(..), TreeIter, treePathCopy, selectionDataCopy) import Data.GI.Gtk.ModelView.Types import GI.Gtk.Structs.TreeIter (getTreeIterStamp, getTreeIterUserData, getTreeIterUserData2, getTreeIterUserData3, setTreeIterStamp, setTreeIterUserData, setTreeIterUserData2, setTreeIterUserData3, TreeIter(..)) import Data.GI.Base (newBoxed, set, get) import Data.GI.Base.Attributes (AttrOp(..)) import Data.GI.Base.Utils (maybeFromPtr) -- import Data.GI.Gtk.General.DNDTypes (SelectionDataM, SelectionData) treeIterOverwrite :: MonadIO m => TreeIter -> TreeIter -> m () treeIterOverwrite iterOut iterIn = do stamp <- getTreeIterStamp iterIn ud1 <- getTreeIterUserData iterIn ud2 <- getTreeIterUserData2 iterIn ud3 <- getTreeIterUserData3 iterIn setTreeIterStamp iterOut stamp setTreeIterUserData iterOut ud1 setTreeIterUserData2 iterOut ud2 setTreeIterUserData3 iterOut ud3 -- A 'CustomStore' is backed by a Gtk2HsStore -- which is an instance of the GtkTreeModel GInterface -- it also stores some extra per-model-type private data -- | A 'CustomStore' is an instance of a Gtk+ 'TreeModel' and can thus be used -- for any widget that stores data in a 'TreeModel'. The user may either -- create an instance of a 'CustomStore' or use one of the pre-defined -- models 'Data.GI.Gtk.ModelView.ListStore.ListStore' or -- 'Data.GI.Gtk.ModelView.TreeStore.TreeStore'. newtype CustomStore private row = CustomStore (ManagedPtr (CustomStore private row)) instance HasParentTypes (CustomStore private row) type instance ParentTypes (CustomStore private row) = '[ TreeModel ] instance TypedObject (CustomStore private row) where glibType = glibType @TreeModel instance GObject (CustomStore private row) where -- | Type synonym for viewing the store as a set of columns. type ColumnMap row = IORef [ColumnAccess row] -- | Create a new 'ColumnMap' value. columnMapNew :: MonadIO m => m (ColumnMap row) columnMapNew = liftIO $ newIORef [] -- | Set or update a column mapping. This function should be used before -- the model is installed into a widget since the number of defined -- columns are only checked once by widgets. customStoreSetColumn :: (MonadIO m, IsTypedTreeModel model) => model row -- ^ the store in which to allocate a new column -> (ColumnId row ty) -- ^ the column that should be set -> (row -> ty) -- ^ the function that sets the property -> m () customStoreSetColumn model (ColumnId _ setter colId) acc | colId<0 = return () | otherwise = liftIO $ do ptr <- withManagedPtr (toTypedTreeModel model) gtk2hs_store_get_impl impl <- deRefStablePtr ptr let cMap = customStoreColumns impl cols <- readIORef cMap let l = fromIntegral $ length cols if colId>=l then do let fillers = replicate (fromIntegral $ colId-l) CAInvalid writeIORef cMap (cols++fillers++[setter acc]) else do let (beg,_:end) = splitAt (fromIntegral colId) cols writeIORef cMap (beg++setter acc:end) data CustomStoreImplementation model row = CustomStoreImplementation { customStoreColumns :: ColumnMap row, -- provide access via columns customStoreIface :: TreeModelIface row, -- functions implementing a tree model customTreeDragSourceIface :: DragSourceIface model row, -- the drag and drop source interface customTreeDragDestIface :: DragDestIface model row -- the drag and drop dest interface } -- | The 'TreeModelIface' structure contains all functions that are required -- to implement an application-specific 'TreeModel'. data TreeModelIface row = TreeModelIface { -- | Return the flags that are valid for this model. treeModelIfaceGetFlags :: IO [TreeModelFlags], -- | Convert an path into the tree into a more concise 'TreeIter'. -- Return @Nothing@ if the path does not exit. treeModelIfaceGetIter :: TreePath -> IO (Maybe TreeIter), -- convert a path to an iterator -- | Convert an iterator to a path. The iterator will always be valid. treeModelIfaceGetPath :: TreeIter -> IO TreePath, -- convert an interator to a path -- | Retrieve a row at the given iterator. treeModelIfaceGetRow :: TreeIter -> IO row, -- get the row at an iter -- | Advance the given iterator to the next node at the same level. -- Return @Nothing@ if there is no next node at this level. treeModelIfaceIterNext :: TreeIter -> IO (Maybe TreeIter), -- following row (if any) -- | Advance the given iterator to the first child of this iterator. -- Return @Notihing@ if the node at this iterator has no children. treeModelIfaceIterChildren :: Maybe TreeIter -> IO (Maybe TreeIter), -- first child row (if any) -- | Check if the node at the given iterator has children. treeModelIfaceIterHasChild :: TreeIter -> IO Bool, -- row has any children at all -- | Query the number of children the the node at the given iteratore has. treeModelIfaceIterNChildren :: Maybe TreeIter -> IO Int, -- number of children of a row -- | Ask for an iterator to the @n@th child. Return @Nothing@ if -- no such child exists. treeModelIfaceIterNthChild :: Maybe TreeIter -> Int -> IO (Maybe TreeIter), -- nth child row of a given row -- | Ask for an iterator to the parent of the node. treeModelIfaceIterParent :: TreeIter -> IO (Maybe TreeIter), -- parent row of a row -- | Increase a reference count for this node. A positive reference count -- indicates that the node is used (that is, most likely it is visible) -- in at least one widget. Tracking reference counts for nodes is -- optional but may be useful to infer when a given row can be discarded -- if it was retrieved from an external source. treeModelIfaceRefNode :: TreeIter -> IO (), -- caching hint -- | Decrement the reference count of the given node. treeModelIfaceUnrefNode :: TreeIter -> IO () -- caching hint } -- | A structure containing functions that enable this widget to be used -- as a source in drag-and-drop. data DragSourceIface model row = DragSourceIface { -- | Determine if the row at the given path is draggable. Return -- @False@ if for some reason this row should not be dragged by -- the user. customDragSourceRowDraggable :: model row -> TreePath -> IO Bool, -- query if the row is draggable -- | Fill in the 'SelectionData' structure with information on -- the given node using -- 'Data.GI.Gtk.General.Selection.selectionDataSet'. customDragSourceDragDataGet :: model row -> TreePath -> SelectionData -> IO Bool, -- store row in selection object -- | The widget is informed that the row at the given path should -- be deleted as the result of this drag. customDragSourceDragDataDelete:: model row -> TreePath -> IO Bool -- instruct store to delete the row } -- | A structure containing functions that enable this widget to be used -- as a target in drag-and-drop. data DragDestIface model row = DragDestIface { -- | Tell the drag-and-drop mechanism if the row can be dropped at the -- given path. customDragDestRowDropPossible :: model row -> TreePath -> SelectionData -> IO Bool, -- query if row drop is possible -- | The data in the 'SelectionDataM' structure should be read using -- 'Data.GI.Gtk.General.Selection.selectionDataGet' and -- its information be used to insert a new row at the given path. customDragDestDragDataReceived:: model row -> TreePath -> SelectionData -> IO Bool -- insert row from selection object } -- | Create a new store that implements the 'TreeModelIface' interface and -- optionally the 'DragSourceIface' and the 'DragDestIface'. If the latter two -- are set to @Nothing@ a dummy interface is substituted that rejects every -- drag and drop. customStoreNew :: (MonadIO m, IsTreeModel (model row), IsTypedTreeModel model) => private -- ^ Any private data the store needs to store. Usually an 'IORef'. -> (CustomStore private row -> model row) -> TreeModelIface row -- ^ Functions necessary to implement the 'TreeModel' interface. -> Maybe (DragSourceIface model row) -- ^ Functions to enable this store to generate drag events. -> Maybe (DragDestIface model row) -- ^ Functions to enable this store to receive drag events. -> m (model row) customStoreNew priv con tmIface mDragSource mDragDest = liftIO $ do cMap <- columnMapNew let dummyDragSource = DragSourceIface { customDragSourceRowDraggable = \_ _ -> return False, customDragSourceDragDataGet = \_ _ _ -> return False, customDragSourceDragDataDelete = \_ _ -> return False } let dummyDragDest = DragDestIface { customDragDestRowDropPossible = \_ _ _ -> return False, customDragDestDragDataReceived = \_ _ _ -> return False } implPtr <- newStablePtr CustomStoreImplementation { customStoreColumns = cMap, customStoreIface = tmIface, customTreeDragSourceIface = fromMaybe dummyDragSource mDragSource, customTreeDragDestIface = fromMaybe dummyDragDest mDragDest } privPtr <- newStablePtr priv storePtr <- gtk2hs_store_new implPtr privPtr con <$> newObject CustomStore storePtr foreign import ccall unsafe "Gtk2HsStore.h gtk2hs_store_new" gtk2hs_store_new :: StablePtr (CustomStoreImplementation model row) -> StablePtr private -> IO (Ptr (CustomStore private row)) -- | Extract a row of the given model at the given 'TreeIter'. -- customStoreGetRow :: (MonadIO m, IsTypedTreeModel model) => model row -> TreeIter -> m row customStoreGetRow model iter = liftIO $ do impl <- withManagedPtr (toTypedTreeModel model) gtk2hs_store_get_impl >>= deRefStablePtr treeModelIfaceGetRow (customStoreIface impl) iter foreign import ccall unsafe "Gtk2HsStore.h gtk2hs_store_get_impl" gtk2hs_store_get_impl :: Ptr (TypedTreeModel row) -> IO (StablePtr (CustomStoreImplementation model row)) -- | Return the private data stored in this 'CustomStore'. The private data -- is meant as a container for the data stored in this model. customStoreGetPrivate :: CustomStore private row -> private customStoreGetPrivate model = unsafePerformIO $ -- this is safe because the priv member is set at -- construction time and never modified after that withManagedPtr model gtk2hs_store_get_priv >>= deRefStablePtr foreign import ccall unsafe "Gtk2HsStore.h gtk2hs_store_get_priv" gtk2hs_store_get_priv :: Ptr (CustomStore private row) -> IO (StablePtr private) -- | Query the current value of the stamp that is used to create -- 'TreeIter' iterators. The stamp is compared each time a view -- accesses this store. If the stamp doesn't match, a warning -- is emitted. The stamp should be updated each time a the data -- in the model changes. The rationale is that a view should never -- use a stale 'TreeIter', i.e., one that refers to an old model. -- customStoreGetStamp :: MonadIO m => CustomStore private row -> m Int32 customStoreGetStamp model = liftIO $ fromIntegral <$> withManagedPtr model gtk2hs_store_get_stamp foreign import ccall unsafe "Gtk2HsStore.h gtk2hs_store_get_stamp" gtk2hs_store_get_stamp :: Ptr (CustomStore private row) -> IO CInt -- | Create a new stamp. See 'customStoreGetStamp'. -- customStoreInvalidateIters :: MonadIO m => CustomStore private row -> m () customStoreInvalidateIters model = liftIO $ withManagedPtr model gtk2hs_store_increment_stamp foreign import ccall unsafe "Gtk2HsStore.h gtk2hs_store_increment_stamp" gtk2hs_store_increment_stamp :: Ptr (CustomStore private row) -> IO () treeModelIfaceGetNColumns_static :: StablePtr (CustomStoreImplementation model row) -> IO CInt treeModelIfaceGetNColumns_static storePtr = do store <- deRefStablePtr storePtr cmap <- readIORef (customStoreColumns store) return (fromIntegral (length cmap)) foreign export ccall "gtk2hs_store_get_n_columns_impl" treeModelIfaceGetNColumns_static :: StablePtr (CustomStoreImplementation model row) -> IO CInt -- Get the 'GType' for a given 'ColumnAccess'. caToGType :: ColumnAccess row -> GType caToGType (CAInt _) = gtypeInt caToGType (CABool _) = gtypeBoolean caToGType (CAString _) = gtypeString caToGType (CAPixbuf _) = gtypePixbuf caToGType CAInvalid = gtypeInt -- to avoid warnings of functions that iterate through all columns gtypePixbuf :: GType gtypePixbuf = unsafePerformIO $ glibType @Pixbuf {-# NOINLINE gtypePixbuf #-} treeModelIfaceGetColumnType_static :: StablePtr (CustomStoreImplementation model row) -> CInt -> IO CGType treeModelIfaceGetColumnType_static storePtr column = do store <- deRefStablePtr storePtr cols <- readIORef (customStoreColumns store) return . gtypeToCGType $ case drop (fromIntegral column) cols of [] -> gtypeInvalid (ca:_) -> caToGType ca foreign export ccall "gtk2hs_store_get_column_type_impl" treeModelIfaceGetColumnType_static :: StablePtr (CustomStoreImplementation model row) -> CInt -> IO CGType treeModelIfaceGetFlags_static :: StablePtr (CustomStoreImplementation model row) -> IO CInt treeModelIfaceGetFlags_static storePtr = do store <- customStoreIface <$> deRefStablePtr storePtr liftM (fromIntegral . gflagsToWord) $ treeModelIfaceGetFlags store foreign export ccall "gtk2hs_store_get_flags_impl" treeModelIfaceGetFlags_static :: StablePtr (CustomStoreImplementation model row) -> IO CInt treeModelIfaceGetIter_static :: StablePtr (CustomStoreImplementation model row) -> Ptr TreeIter -> Ptr TreePath -> IO CInt treeModelIfaceGetIter_static storePtr iterPtr pathPtr = do iterOut <- TreeIter <$> newManagedPtr_ iterPtr -- Take care not to use this outside of this function store <- customStoreIface <$> deRefStablePtr storePtr isOwned' <- newIORef False path <- treePathCopy . TreePath =<< newManagedPtr_ pathPtr treeModelIfaceGetIter store path >>= \case Nothing -> return (fromBool False) Just iter -> do treeIterOverwrite iterOut iter return (fromBool True) foreign export ccall "gtk2hs_store_get_iter_impl" treeModelIfaceGetIter_static :: StablePtr (CustomStoreImplementation model row) -> Ptr TreeIter -> Ptr TreePath -> IO CInt foreign import ccall "gtk_tree_path_copy" gtk_tree_path_copy :: Ptr TreePath -> IO (Ptr TreePath) treeModelIfaceGetPath_static :: StablePtr (CustomStoreImplementation model row) -> Ptr TreeIter -> IO (Ptr TreePath) treeModelIfaceGetPath_static storePtr iterPtr = do store <- customStoreIface <$> deRefStablePtr storePtr iter <- newBoxed TreeIter iterPtr path <- treeModelIfaceGetPath store iter withManagedPtr path gtk_tree_path_copy foreign export ccall "gtk2hs_store_get_path_impl" treeModelIfaceGetPath_static :: StablePtr (CustomStoreImplementation model row) -> Ptr TreeIter -> IO (Ptr TreePath) foreign import ccall "g_value_init" g_value_init :: Ptr GValue -> CGType -> IO (Ptr GValue) foreign import ccall unsafe "g_value_set_int" _set_int32 :: Ptr GValue -> Int32 -> IO () foreign import ccall unsafe "g_value_set_boolean" _set_boolean :: Ptr GValue -> CInt -> IO () foreign import ccall "g_value_set_string" _set_string :: Ptr GValue -> CString -> IO () foreign import ccall "g_value_set_object" _set_object :: Ptr GValue -> Ptr a -> IO () treeModelIfaceGetValue_static :: StablePtr (CustomStoreImplementation model row) -> Ptr TreeIter -> CInt -> Ptr GValue -> IO () treeModelIfaceGetValue_static storePtr iterPtr column gVal = do store <- deRefStablePtr storePtr iter <- newBoxed TreeIter iterPtr row <- treeModelIfaceGetRow (customStoreIface store) iter cols <- readIORef (customStoreColumns store) -- TODO add code to do this check -- 0 <- {# get GValue->g_type #} gVal case drop (fromIntegral column) cols of [] -> void $ g_value_init gVal (gtypeToCGType gtypeInvalid) -- column number out of range (acc:_) -> case acc of (CAInt ca) -> g_value_init gVal (gtypeToCGType gtypeInt) >> _set_int32 gVal (fromIntegral $ ca row) (CABool ca) -> g_value_init gVal (gtypeToCGType gtypeBoolean) >> _set_boolean gVal (fromIntegral . fromEnum $ ca row) (CAString ca) -> g_value_init gVal (gtypeToCGType gtypeString) >> (withTextCString (ca row) $ _set_string gVal) (CAPixbuf ca) -> g_value_init gVal (gtypeToCGType gtypePixbuf) >> (withManagedPtr (ca row) $ _set_object gVal) CAInvalid -> g_value_init gVal (gtypeToCGType gtypeInvalid) >> _set_int32 gVal 0 -- to avoid warnings of functions that iterate through all columns foreign export ccall "gtk2hs_store_get_value_impl" treeModelIfaceGetValue_static :: StablePtr (CustomStoreImplementation model row) -> Ptr TreeIter -> CInt -> Ptr GValue -> IO () treeModelIfaceIterNext_static :: StablePtr (CustomStoreImplementation model row) -> Ptr TreeIter -> IO CInt treeModelIfaceIterNext_static storePtr iterPtr = do iterOut <- TreeIter <$> newManagedPtr_ iterPtr -- Take care not to use this outside of this function store <- customStoreIface <$> deRefStablePtr storePtr iter <- newBoxed TreeIter iterPtr treeModelIfaceIterNext store iter >>= \case Nothing -> return (fromBool False) Just iter' -> do treeIterOverwrite iterOut iter' return (fromBool True) foreign export ccall "gtk2hs_store_iter_next_impl" treeModelIfaceIterNext_static :: StablePtr (CustomStoreImplementation model row) -> Ptr TreeIter -> IO CInt treeModelIfaceIterChildren_static :: StablePtr (CustomStoreImplementation model row) -> Ptr TreeIter -> Ptr TreeIter -> IO CInt treeModelIfaceIterChildren_static storePtr iterPtr parentIterPtr = do iterOut <- TreeIter <$> newManagedPtr_ iterPtr -- Take care not to use this outside of this function store <- customStoreIface <$> deRefStablePtr storePtr parentIter <- maybeNull (newBoxed TreeIter) parentIterPtr treeModelIfaceIterChildren store parentIter >>= \case Nothing -> return (fromBool False) Just iter -> do treeIterOverwrite iterOut iter return (fromBool True) foreign export ccall "gtk2hs_store_iter_children_impl" treeModelIfaceIterChildren_static :: StablePtr (CustomStoreImplementation model row) -> Ptr TreeIter -> Ptr TreeIter -> IO CInt treeModelIfaceIterHasChild_static :: StablePtr (CustomStoreImplementation model row) -> Ptr TreeIter -> IO CInt treeModelIfaceIterHasChild_static storePtr iterPtr = do store <- customStoreIface <$> deRefStablePtr storePtr iter <- newBoxed TreeIter iterPtr fromBool <$> treeModelIfaceIterHasChild store iter foreign export ccall "gtk2hs_store_iter_has_child_impl" treeModelIfaceIterHasChild_static :: StablePtr (CustomStoreImplementation model row) -> Ptr TreeIter -> IO CInt treeModelIfaceIterNChildren_static :: StablePtr (CustomStoreImplementation model row) -> Ptr TreeIter -> IO CInt treeModelIfaceIterNChildren_static storePtr iterPtr = do store <- customStoreIface <$> deRefStablePtr storePtr iter <- maybeNull (newBoxed TreeIter) iterPtr fromIntegral <$> treeModelIfaceIterNChildren store iter foreign export ccall "gtk2hs_store_iter_n_children_impl" treeModelIfaceIterNChildren_static :: StablePtr (CustomStoreImplementation model row) -> Ptr TreeIter -> IO CInt treeModelIfaceIterNthChild_static :: StablePtr (CustomStoreImplementation model row) -> Ptr TreeIter -> Ptr TreeIter -> CInt -> IO CInt treeModelIfaceIterNthChild_static storePtr iterPtr parentIterPtr n = do iterOut <- TreeIter <$> newManagedPtr_ iterPtr -- Take care not to use this outside of this function store <- customStoreIface <$> deRefStablePtr storePtr parentIter <- maybeNull (newBoxed TreeIter) parentIterPtr treeModelIfaceIterNthChild store parentIter (fromIntegral n) >>= \case Nothing -> return (fromBool False) Just iter -> do treeIterOverwrite iterOut iter return (fromBool True) foreign export ccall "gtk2hs_store_iter_nth_child_impl" treeModelIfaceIterNthChild_static :: StablePtr (CustomStoreImplementation model row) -> Ptr TreeIter -> Ptr TreeIter -> CInt -> IO CInt treeModelIfaceIterParent_static :: StablePtr (CustomStoreImplementation model row) -> Ptr TreeIter -> Ptr TreeIter -> IO CInt treeModelIfaceIterParent_static storePtr iterPtr childIterPtr = do iterOut <- TreeIter <$> newManagedPtr_ iterPtr -- Take care not to use this outside of this function store <- customStoreIface <$> deRefStablePtr storePtr childIter <- newBoxed TreeIter childIterPtr iter <- treeModelIfaceIterParent store childIter case iter of Nothing -> return (fromBool False) Just iter -> do treeIterOverwrite iterOut iter return (fromBool True) foreign export ccall "gtk2hs_store_iter_parent_impl" treeModelIfaceIterParent_static :: StablePtr (CustomStoreImplementation model row) -> Ptr TreeIter -> Ptr TreeIter -> IO CInt treeModelIfaceRefNode_static :: StablePtr (CustomStoreImplementation model row) -> Ptr TreeIter -> IO () treeModelIfaceRefNode_static storePtr iterPtr = do store <- customStoreIface <$> deRefStablePtr storePtr iter <- newBoxed TreeIter iterPtr treeModelIfaceRefNode store iter foreign export ccall "gtk2hs_store_ref_node_impl" treeModelIfaceRefNode_static :: StablePtr (CustomStoreImplementation model row) -> Ptr TreeIter -> IO () treeModelIfaceUnrefNode_static :: StablePtr (CustomStoreImplementation model row) -> Ptr TreeIter -> IO () treeModelIfaceUnrefNode_static storePtr iterPtr = do store <- customStoreIface <$> deRefStablePtr storePtr iter <- newBoxed TreeIter iterPtr treeModelIfaceUnrefNode store iter foreign export ccall "gtk2hs_store_unref_node_impl" treeModelIfaceUnrefNode_static :: StablePtr (CustomStoreImplementation model row) -> Ptr TreeIter -> IO () customDragSourceRowDraggable_static :: Ptr TreeModel -> StablePtr (CustomStoreImplementation model row) -> Ptr TreePath -> IO CInt customDragSourceRowDraggable_static mPtr storePtr pathPtr = do model <- newObject TreeModel mPtr store <- customTreeDragSourceIface <$> deRefStablePtr storePtr path <- treePathCopy . TreePath =<< newManagedPtr_ pathPtr fromBool <$> customDragSourceRowDraggable store (unsafeTreeModelToGeneric model) path foreign export ccall "gtk2hs_store_row_draggable_impl" customDragSourceRowDraggable_static :: Ptr TreeModel -> StablePtr (CustomStoreImplementation model row) -> Ptr TreePath -> IO CInt customDragSourceDragDataGet_static :: Ptr TreeModel -> StablePtr (CustomStoreImplementation model row) -> Ptr TreePath -> Ptr SelectionData -> IO CInt customDragSourceDragDataGet_static mPtr storePtr pathPtr selectionPtr = do model <- newObject TreeModel mPtr store <- customTreeDragSourceIface <$> deRefStablePtr storePtr path <- treePathCopy . TreePath =<< newManagedPtr_ pathPtr selection <- selectionDataCopy . SelectionData =<< newManagedPtr_ selectionPtr fromBool <$> customDragSourceDragDataGet store (unsafeTreeModelToGeneric model) path selection foreign export ccall "gtk2hs_store_drag_data_get_impl" customDragSourceDragDataGet_static :: Ptr TreeModel -> StablePtr (CustomStoreImplementation model row) -> Ptr TreePath -> Ptr SelectionData -> IO CInt customDragSourceDragDataDelete_static :: Ptr TreeModel -> StablePtr (CustomStoreImplementation model row) -> Ptr TreePath -> IO CInt customDragSourceDragDataDelete_static mPtr storePtr pathPtr = do model <- newObject TreeModel mPtr store <- customTreeDragSourceIface <$> deRefStablePtr storePtr path <- treePathCopy . TreePath =<< newManagedPtr_ pathPtr fromBool <$> customDragSourceDragDataDelete store (unsafeTreeModelToGeneric model) path foreign export ccall "gtk2hs_store_drag_data_delete_impl" customDragSourceDragDataDelete_static :: Ptr TreeModel -> StablePtr (CustomStoreImplementation model row) -> Ptr TreePath -> IO CInt customDragDestDragDataReceived_static :: Ptr TreeModel -> StablePtr (CustomStoreImplementation model row) -> Ptr TreePath -> Ptr SelectionData -> IO CInt customDragDestDragDataReceived_static mPtr storePtr pathPtr selectionPtr = do model <- newObject TreeModel mPtr store <- customTreeDragDestIface <$> deRefStablePtr storePtr path <- treePathCopy . TreePath =<< newManagedPtr_ pathPtr selection <- selectionDataCopy . SelectionData =<< newManagedPtr_ selectionPtr fromBool <$> customDragDestDragDataReceived store (unsafeTreeModelToGeneric model) path selection foreign export ccall "gtk2hs_store_drag_data_received_impl" customDragDestDragDataReceived_static :: Ptr TreeModel -> StablePtr (CustomStoreImplementation model row) -> Ptr TreePath -> Ptr SelectionData -> IO CInt customDragDestRowDropPossible_static :: Ptr TreeModel -> StablePtr (CustomStoreImplementation model row) -> Ptr TreePath -> Ptr SelectionData -> IO CInt customDragDestRowDropPossible_static mPtr storePtr pathPtr selectionPtr = do model <- newObject TreeModel mPtr store <- customTreeDragDestIface <$> deRefStablePtr storePtr path <- treePathCopy . TreePath =<< newManagedPtr_ pathPtr selection <- selectionDataCopy . SelectionData =<< newManagedPtr_ selectionPtr fromBool <$> customDragDestRowDropPossible store (unsafeTreeModelToGeneric model) path selection foreign export ccall "gtk2hs_store_row_drop_possible_impl" customDragDestRowDropPossible_static :: Ptr TreeModel -> StablePtr (CustomStoreImplementation model row) -> Ptr TreePath -> Ptr SelectionData -> IO CInt maybeNull :: (Ptr a -> IO b) -> Ptr a -> IO (Maybe b) maybeNull marshal ptr | ptr == nullPtr = return Nothing | otherwise = liftM Just (marshal ptr) gi-gtk-hs-0.3.9/src/Data/GI/Gtk/ModelView/ForestStore.hs0000644000000000000000000007606407346545000020715 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} -- -*-haskell-*- -- GIMP Toolkit (GTK) CustomStore TreeModel -- -- Author : Duncan Coutts, Axel Simon -- -- Created: 11 Feburary 2006 -- -- Copyright (C) 2005-2016 Duncan Coutts, Axel Simon, Hamish Mackenzie -- -- 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. -- -- | -- Stability : provisional -- Portability : portable (depends on GHC) -- -- Standard model to store hierarchical data. -- module Data.GI.Gtk.ModelView.ForestStore ( -- * Types ForestStore(..), -- * Constructors forestStoreNew, forestStoreNewDND, -- * Implementation of Interfaces forestStoreDefaultDragSourceIface, forestStoreDefaultDragDestIface, -- * Methods forestStoreGetValue, forestStoreGetTree, forestStoreGetForest, forestStoreLookup, forestStoreSetValue, forestStoreInsert, forestStoreInsertTree, forestStoreInsertForest, forestStoreRemove, forestStoreClear, forestStoreChange, forestStoreChangeM, ) where import Prelude () import Prelude.Compat import Data.Bits import Data.Word (Word32) import Data.Int (Int32) import Data.Maybe ( fromMaybe, isJust ) import Data.Tree import Control.Monad ((>=>), when) import Control.Monad.IO.Class (MonadIO(..)) import Control.Exception (assert) import Data.IORef import Foreign.ForeignPtr (ForeignPtr) import Data.GI.Base.BasicTypes (TypedObject(..), ManagedPtr(..), GObject) import Data.GI.Base.ManagedPtr (withManagedPtr) import Data.GI.Base.Overloading (HasParentTypes, ParentTypes) import Data.GI.Gtk.ModelView.Types import Data.GI.Gtk.ModelView.CustomStore (customStoreGetStamp, customStoreGetPrivate, TreeModelIface(..), customStoreNew, DragDestIface(..), DragSourceIface(..), CustomStore(..), customStoreInvalidateIters) import GI.GObject.Objects.Object (Object(..)) import GI.Gtk.Interfaces.TreeModel (treeModelRowDeleted, treeModelRowInserted, treeModelRowChanged, toTreeModel, TreeModel(..), IsTreeModel(..), treeModelRowHasChildToggled) import GI.Gtk.Functions (treeSetRowDragData, treeGetRowDragData) import GI.Gtk.Structs.TreePath (TreePath) import GI.Gtk.Structs.TreeIter (getTreeIterUserData3, getTreeIterUserData2, getTreeIterUserData, getTreeIterStamp, setTreeIterUserData3, setTreeIterUserData2, setTreeIterUserData, setTreeIterStamp, TreeIter(..)) import Data.GI.Base (get, new) import Unsafe.Coerce (unsafeCoerce) -------------------------------------------- -- internal model data types -- data ForestStoreIter = ForestStoreIter Int32 Word32 Word32 Word32 fromForestStoreIter :: MonadIO m => ForestStoreIter -> m TreeIter fromForestStoreIter (ForestStoreIter s u1 u2 u3) = do i <- new TreeIter [] setTreeIterStamp i s setTreeIterUserData i $ unsafeCoerce u1 setTreeIterUserData2 i $ unsafeCoerce u2 setTreeIterUserData3 i $ unsafeCoerce u3 return i toForestStoreIter :: MonadIO m => TreeIter -> m ForestStoreIter toForestStoreIter iter = do stamp <- getTreeIterStamp iter u1 <- getTreeIterUserData iter u2 <- getTreeIterUserData2 iter u3 <- getTreeIterUserData3 iter return $ ForestStoreIter stamp (unsafeCoerce u1) (unsafeCoerce u2) (unsafeCoerce u3) forestStoreIterSetStamp :: ForestStoreIter -> Int32 -> ForestStoreIter forestStoreIterSetStamp (ForestStoreIter _ a b c) s = ForestStoreIter s a b c -- | A store for hierarchical data. -- newtype ForestStore a = ForestStore (ManagedPtr (CustomStore (IORef (Store a)) a)) mkForestStore :: CustomStore (IORef (Store a)) a -> ForestStore a mkForestStore (CustomStore ptr) = ForestStore ptr instance HasParentTypes (ForestStore a) type instance ParentTypes (ForestStore a) = '[TreeModel] instance TypedObject (ForestStore a) where glibType = glibType @TreeModel instance GObject (ForestStore a) instance IsTypedTreeModel ForestStore -- | Maximum number of nodes on each level. -- -- * These numbers determine how many bits in a 'TreeIter' are devoted to -- each level. Hence, these numbers reflect log2 of the maximum number -- of nodes at a level, rounded up. -- type Depth = [Int] data Store a = Store { depth :: Depth, content :: Cache a } -- | Create a new list store. -- -- * The given rose tree determines the initial content and may be the empty -- list. Each 'Tree' in the forest corresponds to one top-level node. -- -- * The ForestStore maintains the initially given Forest and aligns the 'TreePath' -- bits to fit in 96-bit length 'TreeIter' storage. -- -- * Additionally, a cache is used to achieve higher performance if operating on -- recently used TreePaths. -- -- * __Note:__ due to the limited amount of bits available in TreeIter storage, only -- limited depth forests can be used with this implementation, the result of too deep -- Forests is an undefined behaviour while trying to retrieve the deeply nested nodes. -- For example: assuming the average requiement is 8 bits per tree level (max number of -- children at the level is 255), then we can only use 12 levels deep trees (96/8) - -- any further levels in a TreePath will not be encoded in the corresponding TreeIter -- storage. -- forestStoreNew :: MonadIO m => Forest a -> m (ForestStore a) forestStoreNew forest = forestStoreNewDND forest (Just forestStoreDefaultDragSourceIface) (Just forestStoreDefaultDragDestIface) -- | Create a new list store. -- -- * In addition to 'forestStoreNew', this function takes an two interfaces -- to implement user-defined drag-and-drop functionality. -- forestStoreNewDND :: MonadIO m => Forest a -- ^ the inital tree stored in this model -> Maybe (DragSourceIface ForestStore a) -- ^ an optional interface for drags -> Maybe (DragDestIface ForestStore a) -- ^ an optional interface to handle drops -> m (ForestStore a) forestStoreNewDND forest mDSource mDDest = liftIO $ do (storeRef :: IORef (Store a)) <- newIORef Store { depth = calcForestDepth forest, content = storeToCache forest } let withStore :: (Store a -> IO result) -> IO result withStore f = readIORef storeRef >>= f withStoreUpdateCache :: (Store a -> (result, Cache a)) -> IO result withStoreUpdateCache f = do store <- readIORef storeRef let (result, cache') = f store writeIORef storeRef store { content = cache' } return result customStoreNew storeRef mkForestStore TreeModelIface { treeModelIfaceGetFlags = return [], treeModelIfaceGetIter = \path -> withStore $ \Store { depth = d } -> fromPath d <$> treePathGetIndices' path >>= mapM fromForestStoreIter, treeModelIfaceGetPath = toForestStoreIter >=> \iter -> withStore $ \Store { depth = d } -> treePathNewFromIndices' $ toPath d iter, treeModelIfaceGetRow = toForestStoreIter >=> \iter -> withStoreUpdateCache $ \Store { depth = d, content = cache } -> case checkSuccess d iter cache of (True, cache'@((_, (Node { rootLabel = val }:_)):_)) -> (val, cache') _ -> error "ForestStore.getRow: iter does not refer to a valid entry", treeModelIfaceIterNext = toForestStoreIter >=> \iter -> withStoreUpdateCache ( \Store { depth = d, content = cache } -> iterNext d iter cache) >>= mapM fromForestStoreIter, treeModelIfaceIterChildren = \mIter -> do iter <- maybe (return invalidIter) toForestStoreIter mIter withStoreUpdateCache ( \Store { depth = d, content = cache } -> iterNthChild d 0 iter cache) >>= mapM fromForestStoreIter, treeModelIfaceIterHasChild = toForestStoreIter >=> \iter -> withStoreUpdateCache $ \Store { depth = d, content = cache } -> let (mIter, cache') = iterNthChild d 0 iter cache in (isJust mIter, cache'), treeModelIfaceIterNChildren = mapM toForestStoreIter >=> \mIter -> withStoreUpdateCache $ \Store { depth = d, content = cache } -> let iter = fromMaybe invalidIter mIter in iterNChildren d iter cache, treeModelIfaceIterNthChild = \mIter idx -> do iter <- maybe (return invalidIter) toForestStoreIter mIter withStoreUpdateCache ( \Store { depth = d, content = cache } -> iterNthChild d idx iter cache) >>= mapM fromForestStoreIter, treeModelIfaceIterParent = toForestStoreIter >=> \iter -> withStore $ \Store { depth = d } -> mapM fromForestStoreIter (iterParent d iter), treeModelIfaceRefNode = \_ -> return (), treeModelIfaceUnrefNode = \_ -> return () } mDSource mDDest -- | Default drag functions for -- 'Data.GI.Gtk.ModelView.ForestStore'. These functions allow the rows of -- the model to serve as drag source. Any row is allowed to be dragged and the -- data set in the 'SelectionDataM' object is set with 'treeSetRowDragData', -- i.e. it contains the model and the 'TreePath' to the row. forestStoreDefaultDragSourceIface :: DragSourceIface ForestStore row forestStoreDefaultDragSourceIface = DragSourceIface { customDragSourceRowDraggable = \_ _-> return True, customDragSourceDragDataGet = \model path sel -> treeSetRowDragData sel model path, customDragSourceDragDataDelete = \model path -> treePathGetIndices' path >>= \dest@(_:_) -> do liftIO $ forestStoreRemove model path return True } -- | Default drop functions for 'Data.GI.Gtk.ModelView.ForestStore'. These -- functions accept a row and insert the row into the new location if it is -- dragged into a tree view -- that uses the same model. forestStoreDefaultDragDestIface :: DragDestIface ForestStore row forestStoreDefaultDragDestIface = DragDestIface { customDragDestRowDropPossible = \model path sel -> do mModelPath <- treeGetRowDragData sel case mModelPath of (True, Just model', source) -> do tm <- toTreeModel model withManagedPtr tm $ \m -> withManagedPtr model' $ \m' -> return (m==m') _ -> return False, customDragDestDragDataReceived = \model path sel -> do dest@(_:_) <- treePathGetIndices' path mModelPath <- treeGetRowDragData sel case mModelPath of (True, Just model', Just path) -> do source@(_:_) <- treePathGetIndices' path tm <- toTreeModel model withManagedPtr tm $ \m -> withManagedPtr model' $ \m' -> if m/=m' then return False else do row <- forestStoreGetTree model =<< treePathNewFromIndices' source initPath <- treePathNewFromIndices' (init dest) forestStoreInsertTree model initPath (fromIntegral $ last dest) row return True _ -> return False } -------------------------------------------- -- low level bit-twiddling utility functions -- bitsNeeded :: Word32 -> Int bitsNeeded n = bitsNeeded' 0 n where bitsNeeded' b 0 = b bitsNeeded' b n = bitsNeeded' (b+1) (n `shiftR` 1) getBitSlice :: ForestStoreIter -> Int -> Int -> Word32 getBitSlice (ForestStoreIter _ a b c) off count = getBitSliceWord a off count .|. getBitSliceWord b (off-32) count .|. getBitSliceWord c (off-64) count where getBitSliceWord :: Word32 -> Int -> Int -> Word32 getBitSliceWord word off count = word `shift` (-off) .&. (1 `shiftL` count - 1) setBitSlice :: ForestStoreIter -> Int -> Int -> Word32 -> ForestStoreIter setBitSlice (ForestStoreIter stamp a b c) off count value = assert (value < 1 `shiftL` count) $ ForestStoreIter stamp (setBitSliceWord a off count value) (setBitSliceWord b (off-32) count value) (setBitSliceWord c (off-64) count value) where setBitSliceWord :: Word32 -> Int -> Int -> Word32 -> Word32 setBitSliceWord word off count value = let mask = (1 `shiftL` count - 1) `shift` off in (word .&. complement mask) .|. (value `shift` off) --iterPrefixEqual :: TreeIter -> TreeIter -> Int -> Bool --iterPrefixEqual (TreeIter _ a1 b1 c1) (TreeIter _ a2 b2 c2) pos -- | pos>64 = let mask = 1 `shiftL` (pos-64) - 1 in -- a1==a2 && b1==b2 && (c1 .&. mask) == (c2 .&. mask) -- | pos>32 = let mask = 1 `shiftL` (pos-32) - 1 in -- a1==a2 && (b1 .&. mask) == (b2 .&. mask) -- | otherwise = let mask = 1 `shiftL` pos - 1 in -- (a1 .&. mask) == (a2 .&. mask) -- | The invalid tree iterator. -- invalidIter :: ForestStoreIter invalidIter = ForestStoreIter 0 0 0 0 --showIterBits (TreeIter _ a b c) = [showBits a, showBits b, showBits c] -- --showBits :: Bits a => a -> String --showBits a = [ if testBit a i then '1' else '0' | i <- [0..bitSize a - 1] ] -- | Calculate the maximum number of nodes on a per-level basis. -- calcForestDepth :: Forest a -> Depth calcForestDepth f = map bitsNeeded $ takeWhile (/=0) $ foldr calcTreeDepth (repeat 0) f where calcTreeDepth Node { subForest = f } (d:ds) = (d+1): zipWith max ds (foldr calcTreeDepth (repeat 0) f) -- | Convert an iterator into a path. -- toPath :: Depth -> ForestStoreIter -> [Int32] toPath d iter = gP 0 d where gP pos [] = [] gP pos (d:ds) = let idx = getBitSlice iter pos d in if idx==0 then [] else fromIntegral (idx-1) : gP (pos+d) ds -- | Try to convert a path into a 'TreeIter'. -- fromPath :: Depth -> [Int32] -> Maybe ForestStoreIter fromPath = fP 0 invalidIter where fP pos ti _ [] = Just ti -- the remaining bits are zero anyway fP pos ti [] _ = Nothing fP pos ti (d:ds) (p:ps) = let idx = fromIntegral (p+1) in if idx >= bit d then Nothing else fP (pos+d) (setBitSlice ti pos d idx) ds ps -- | The 'Cache' type synonym is only used iternally. What it represents -- the stack during a (fictional) lookup operations. -- The topmost frame is the node -- for which this lookup was started and the innermost frame (the last -- element of the list) contains the root of the tree. -- type Cache a = [(ForestStoreIter, Forest a)] -- | Create a traversal structure that allows a pre-order traversal in linear -- time. -- -- * The returned structure points at the root of the first level which doesn't -- really exist, but serves to indicate that it is before the very first -- node. -- storeToCache :: Forest a -> Cache a storeToCache [] = [] storeToCache forest = [(invalidIter, [Node root forest])] where root = error "ForestStore.storeToCache: accessed non-exitent root of tree" -- | Extract the store from the cache data structure. cacheToStore :: Cache a -> Forest a cacheToStore [] = [] cacheToStore cache = case last cache of (_, [Node _ forest]) -> forest -- | Advance the traversal structure to the given 'TreeIter'. -- advanceCache :: Depth -> ForestStoreIter -> Cache a -> Cache a advanceCache depth goal [] = [] advanceCache depth goal cache@((rootIter,_):_) = moveToSameLevel 0 depth where moveToSameLevel pos [] = cache moveToSameLevel pos (d:ds) = let goalIdx = getBitSlice goal pos d curIdx = getBitSlice rootIter pos d isNonZero pos d (ti,_) = getBitSlice ti pos d/=0 in if goalIdx==curIdx then moveToSameLevel (pos+d) ds else if goalIdx==0 then dropWhile (isNonZero pos d) cache else if curIdx==0 then moveToChild pos (d:ds) cache else if goalIdx cache (d':_) -> dropWhile (isNonZero (pos+d) d') cache -- Descend into the topmost forest to find the goal iterator. The position -- and the remainding depths specify the index in the cache that is zero. -- All indices in front of pos coincide with that of the goal iterator. moveToChild :: Int -> Depth -> Cache a -> Cache a moveToChild pos [] cache = cache -- we can't set more than the leaf moveToChild pos (d:ds) cache@((ti,forest):parents) | getBitSlice goal pos d == 0 = cache | otherwise = case forest of [] -> cache -- impossible request Node { subForest = children }:_ -> let childIdx :: Int childIdx = fromIntegral (getBitSlice goal pos d)-1 (dropped, remain) = splitAt childIdx children advanced = length dropped ti' = setBitSlice ti pos d (fromIntegral advanced+1) in if advanced ForestStoreIter -> Cache a -> (Bool, Cache a) checkSuccess depth iter cache = case advanceCache depth iter cache of cache'@((cur,sibs):_) -> (cmp cur iter && not (null sibs), cache') [] -> (False, []) where cmp (ForestStoreIter _ a1 b1 c1) (ForestStoreIter _ a2 b2 c2) = a1==a2 && b1==b2 && c2==c2 -- | Get the leaf index of this iterator. -- -- * Due to the way we construct the 'TreeIter's, we can check which the last -- level of an iterator is: The bit sequence of level n is zero if n is -- greater or equal to the level that the iterator refers to. The returned -- triple is (pos, leaf, zero) such that pos..pos+leaf denotes the leaf -- index and pos+leaf..pos+leaf+zero denotes the bit field that is zero. -- getTreeIterLeaf :: Depth -> ForestStoreIter -> (Int, Int, Int) getTreeIterLeaf ds ti = gTIL 0 0 ds where gTIL pos dCur (dNext:ds) | getBitSlice ti (pos+dCur) dNext==0 = (pos,dCur,dNext) | otherwise = gTIL (pos+dCur) dNext ds gTIL pos d [] = (pos, d, 0) -- | Move an iterator forwards on the same level. -- iterNext :: Depth -> ForestStoreIter -> Cache a -> (Maybe ForestStoreIter, Cache a) iterNext depth iter cache = let (pos,leaf,_child) = getTreeIterLeaf depth iter curIdx = getBitSlice iter pos leaf nextIdx = curIdx+1 nextIter = setBitSlice iter pos leaf nextIdx in if nextIdx==bit leaf then (Nothing, cache) else case checkSuccess depth nextIter cache of (True, cache) -> (Just nextIter, cache) (False, cache) -> (Nothing, cache) -- | Move down to the child of the given iterator. -- iterNthChild :: Depth -> Int -> ForestStoreIter -> Cache a -> (Maybe ForestStoreIter, Cache a) iterNthChild depth childIdx_ iter cache = let (pos,leaf,child) = getTreeIterLeaf depth iter childIdx = fromIntegral childIdx_+1 nextIter = setBitSlice iter (pos+leaf) child childIdx in if childIdx>=bit child then (Nothing, cache) else case checkSuccess depth nextIter cache of (True, cache) -> (Just nextIter, cache) (False, cache) -> (Nothing, cache) -- | Descend to the first child. -- iterNChildren :: Depth -> ForestStoreIter -> Cache a -> (Int, Cache a) iterNChildren depth iter cache = case checkSuccess depth iter cache of (True, cache@((_,Node { subForest = forest}:_):_)) -> (length forest, cache) (_, cache) -> (0, cache) -- | Ascend to parent. -- iterParent :: Depth -> ForestStoreIter -> Maybe ForestStoreIter iterParent depth iter = let (pos,leaf,_child) = getTreeIterLeaf depth iter in if pos==0 then Nothing else if getBitSlice iter pos leaf==0 then Nothing else Just (setBitSlice iter pos leaf 0) -- | Insert nodes into the store. -- -- * The given list of nodes is inserted into given parent at @pos@. -- If the parent existed, the function returns @Just path@ where @path@ -- is the position of the newly inserted elements. If @pos@ is negative -- or greater or equal to the number of children of the node at @path@, -- the new nodes are appended to the list. -- forestStoreInsertForest :: MonadIO m => ForestStore a -- ^ the store -> TreePath -- ^ @path@ - the position of the parent -> Int -- ^ @pos@ - the index of the new tree -> Forest a -- ^ the list of trees to be inserted -> m () forestStoreInsertForest (ForestStore model) path pos nodes = liftIO $ do ipath <- treePathGetIndices' path customStoreInvalidateIters $ CustomStore model (idx, toggle) <- atomicModifyIORef (customStoreGetPrivate $ CustomStore model) $ \store@Store { depth = d, content = cache } -> case insertIntoForest (cacheToStore cache) nodes ipath pos of Nothing -> error ("forestStoreInsertForest: path does not exist " ++ show ipath) Just (newForest, idx, toggle) -> let depth = calcForestDepth newForest in (Store { depth = depth, content = storeToCache newForest }, (idx, toggle)) Store { depth = depth } <- readIORef (customStoreGetPrivate $ CustomStore model) let rpath = reverse ipath stamp <- customStoreGetStamp $ CustomStore model sequence_ [ let p' = reverse p Just iter = fromPath depth p' in do p'' <- treePathNewFromIndices' p' treeModelRowInserted (CustomStore model) p'' =<< fromForestStoreIter (forestStoreIterSetStamp iter stamp) | (i, node) <- zip [idx..] nodes , p <- paths (fromIntegral i : rpath) node ] let Just iter = fromPath depth ipath when toggle $ treeModelRowHasChildToggled (CustomStore model) path =<< fromForestStoreIter (forestStoreIterSetStamp iter stamp) where paths :: [Int32] -> Tree a -> [[Int32]] paths path Node { subForest = ts } = path : concat [ paths (n:path) t | (n, t) <- zip [0..] ts ] -- | Insert a node into the store. -- forestStoreInsertTree :: MonadIO m => ForestStore a -- ^ the store -> TreePath -- ^ @path@ - the position of the parent -> Int -- ^ @pos@ - the index of the new tree -> Tree a -- ^ the value to be inserted -> m () forestStoreInsertTree store path pos node = forestStoreInsertForest store path pos [node] -- | Insert a single node into the store. -- -- * This function inserts a single node without children into the tree. -- Its arguments are similar to those of 'forestStoreInsert'. -- forestStoreInsert :: MonadIO m => ForestStore a -- ^ the store -> TreePath -- ^ @path@ - the position of the parent -> Int -- ^ @pos@ - the index of the new tree -> a -- ^ the value to be inserted -> m () forestStoreInsert store path pos node = forestStoreInsertForest store path pos [Node node []] -- | Insert nodes into a forest. -- -- * If the parent was found, returns the new tree, the child number -- and a flag denoting if these new nodes were the first children -- of the parent. -- insertIntoForest :: Forest a -> Forest a -> [Int32] -> Int -> Maybe (Forest a, Int, Bool) insertIntoForest forest nodes [] pos | pos<0 = Just (forest++nodes, length forest, null forest) | otherwise = Just (prev++nodes++next, length prev, null forest) where (prev, next) = splitAt pos forest insertIntoForest forest nodes (p:ps) pos = case splitAt (fromIntegral p) forest of (prev, []) -> Nothing (prev, Node { rootLabel = val, subForest = for}:next) -> case insertIntoForest for nodes ps pos of Nothing -> Nothing Just (for, pos, toggle) -> Just (prev++Node { rootLabel = val, subForest = for }:next, pos, toggle) -- | Remove a node from the store. -- -- * The node denoted by the path is removed, along with all its children. -- The function returns @True@ if the given node was found. -- forestStoreRemove :: MonadIO m => ForestStore a -> TreePath -> m Bool forestStoreRemove model path = treePathGetIndices' path >>= forestStoreRemoveImpl model path forestStoreRemoveImpl :: MonadIO m => ForestStore a -> TreePath -> [Int32] -> m Bool --TODO: eliminate this special case without segfaulting! forestStoreRemoveImpl (ForestStore model) _ [] = return False forestStoreRemoveImpl (ForestStore model) path ipath = liftIO $ do customStoreInvalidateIters (CustomStore model) (found, toggle) <- atomicModifyIORef (customStoreGetPrivate (CustomStore model)) $ \store@Store { depth = d, content = cache } -> if null cache then (store, (False, False)) else case deleteFromForest (cacheToStore cache) ipath of Nothing -> (store, (False, False)) Just (newForest, toggle) -> (Store { depth = d, -- this might be a space leak content = storeToCache newForest }, (True, toggle)) when found $ do when (toggle && not (null ipath)) $ do Store { depth = depth } <- readIORef (customStoreGetPrivate (CustomStore model)) let iparent = init ipath Just iter = fromPath depth iparent parent <- treePathNewFromIndices' iparent treeModelRowHasChildToggled (CustomStore model) parent =<< fromForestStoreIter iter treeModelRowDeleted (CustomStore model) path return found forestStoreClear :: MonadIO m => ForestStore a -> m () forestStoreClear (ForestStore model) = liftIO $ do customStoreInvalidateIters (CustomStore model) Store { content = cache } <- readIORef (customStoreGetPrivate (CustomStore model)) let forest = cacheToStore cache writeIORef (customStoreGetPrivate (CustomStore model)) Store { depth = calcForestDepth [], content = storeToCache [] } let loop (-1) = return () loop n = treePathNewFromIndices' [fromIntegral n] >>= treeModelRowDeleted (CustomStore model) >> loop (n-1) loop (length forest - 1) -- | Remove a node from a rose tree. -- -- * Returns the new tree if the node was found. The returned flag is -- @True@ if deleting the node left the parent without any children. -- deleteFromForest :: Forest a -> [Int32] -> Maybe (Forest a, Bool) deleteFromForest forest [] = Just ([], False) deleteFromForest forest (p:ps) = case splitAt (fromIntegral p) forest of (prev, kill@Node { rootLabel = val, subForest = for}:next) -> if null ps then Just (prev++next, null prev && null next) else case deleteFromForest for ps of Nothing -> Nothing Just (for,toggle) -> Just (prev++Node {rootLabel = val, subForest = for }:next, toggle) (prev, []) -> Nothing -- | Set a node in the store. -- forestStoreSetValue :: MonadIO m => ForestStore a -> TreePath -> a -> m () forestStoreSetValue store path value = forestStoreChangeM store path (\_ -> return value) >> return () -- | Change a node in the store. -- -- * Returns @True@ if the node was found. For a monadic version, see -- 'forestStoreChangeM'. -- forestStoreChange :: MonadIO m => ForestStore a -> TreePath -> (a -> a) -> m Bool forestStoreChange store path func = forestStoreChangeM store path (return . func) -- | Change a node in the store. -- -- * Returns @True@ if the node was found. For a purely functional version, see -- 'forestStoreChange'. -- forestStoreChangeM :: MonadIO m => ForestStore a -> TreePath -> (a -> m a) -> m Bool forestStoreChangeM (ForestStore model) path act = do ipath <- treePathGetIndices' path customStoreInvalidateIters (CustomStore model) store@Store { depth = d, content = cache } <- liftIO $ readIORef (customStoreGetPrivate (CustomStore model)) (store'@Store { depth = d, content = cache }, found) <- do mRes <- changeForest (cacheToStore cache) act ipath return $ case mRes of Nothing -> (store, False) Just newForest -> (Store { depth = d, content = storeToCache newForest }, True) liftIO $ writeIORef (customStoreGetPrivate (CustomStore model)) store' let Just iter = fromPath d ipath stamp <- customStoreGetStamp (CustomStore model) when found $ treeModelRowChanged (CustomStore model) path =<< fromForestStoreIter (forestStoreIterSetStamp iter stamp) return found -- | Change a node in the forest. -- -- * Returns @True@ if the given node was found. -- changeForest :: MonadIO m => Forest a -> (a -> m a) -> [Int32] -> m (Maybe (Forest a)) changeForest forest act [] = return Nothing changeForest forest act (p:ps) = case splitAt (fromIntegral p) forest of (prev, []) -> return Nothing (prev, Node { rootLabel = val, subForest = for}:next) -> if null ps then do val' <- act val return (Just (prev++Node { rootLabel = val', subForest = for }:next)) else do mFor <- changeForest for act ps case mFor of Nothing -> return Nothing Just for -> return $ Just (prev++Node { rootLabel = val, subForest = for }:next) -- | Extract one node from the current model. Fails if the given -- 'TreePath' refers to a non-existent node. -- forestStoreGetValue :: (Applicative m, MonadIO m) => ForestStore a -> TreePath -> m a forestStoreGetValue model path = rootLabel <$> forestStoreGetTree model path -- | Extract a subtree from the current model. Fails if the given -- 'TreePath' refers to a non-existent node. -- forestStoreGetTree :: MonadIO m => ForestStore a -> TreePath -> m (Tree a) forestStoreGetTree (ForestStore model) path = liftIO $ do ipath <- treePathGetIndices' path store@Store { depth = d, content = cache } <- readIORef (customStoreGetPrivate (CustomStore model)) case fromPath d ipath of (Just iter) -> do let (res, cache') = checkSuccess d iter cache writeIORef (customStoreGetPrivate (CustomStore model)) store { content = cache' } case cache' of ((_,node:_):_) | res -> return node _ -> fail ("forestStoreGetTree: path does not exist " ++ show ipath) _ -> fail ("forestStoreGetTree: path does not exist " ++ show ipath) -- | Extract the forest from the current model. -- forestStoreGetForest :: MonadIO m => ForestStore a -> m (Forest a) forestStoreGetForest (ForestStore model) = liftIO $ do store@Store { depth = d, content = cache } <- readIORef (customStoreGetPrivate (CustomStore model)) return $ cacheToStore cache -- | Extract a subtree from the current model. Like 'forestStoreGetTree' -- but returns @Nothing@ if the path refers to a non-existant node. -- forestStoreLookup :: MonadIO m => ForestStore a -> TreePath -> m (Maybe (Tree a)) forestStoreLookup (ForestStore model) path = liftIO $ do ipath <- treePathGetIndices' path store@Store { depth = d, content = cache } <- readIORef (customStoreGetPrivate (CustomStore model)) case fromPath d ipath of (Just iter) -> do let (res, cache') = checkSuccess d iter cache writeIORef (customStoreGetPrivate (CustomStore model)) store { content = cache' } case cache' of ((_,node:_):_) | res -> return (Just node) _ -> return Nothing _ -> return Nothing gi-gtk-hs-0.3.9/src/Data/GI/Gtk/ModelView/SeqStore.hs0000644000000000000000000003775007346545000020202 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeApplications #-} -- -*-haskell-*- -- GIMP Toolkit (GTK) CustomStore TreeModel -- -- Author : Duncan Coutts, Axel Simon -- -- Created: 11 Feburary 2006 -- -- Copyright (C) 2005-2016 Duncan Coutts, Axel Simon, Hamish Mackenzie -- -- 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. -- -- | -- Stability : provisional -- Portability : portable (depends on GHC) -- -- Standard model to store list data. -- module Data.GI.Gtk.ModelView.SeqStore ( -- * Types SeqStore(..), -- * Constructors seqStoreNew, seqStoreNewDND, -- * Implementation of Interfaces seqStoreDefaultDragSourceIface, seqStoreDefaultDragDestIface, -- * Methods seqStoreIterToIndex, seqStoreGetValue, seqStoreSafeGetValue, seqStoreSetValue, seqStoreToList, seqStoreGetSize, seqStoreInsert, seqStoreInsertBefore, seqStoreInsertAfter, seqStorePrepend, seqStoreAppend, seqStoreRemove, seqStoreClear, ) where import Prelude () import Prelude.Compat import Control.Monad (when) import Control.Monad.Trans ( liftIO ) import Data.IORef import Data.Ix (inRange) import Foreign.ForeignPtr (ForeignPtr) import qualified Data.Sequence as Seq import Data.Sequence (Seq) import qualified Data.Foldable as F import Data.Int (Int32) import Data.GI.Gtk.ModelView.Types import Data.GI.Gtk.ModelView.CustomStore (customStoreGetStamp, customStoreGetPrivate, TreeModelIface(..), customStoreNew, DragDestIface(..), DragSourceIface(..), CustomStore(..)) import Data.GI.Base.BasicTypes (TypedObject(..), ManagedPtr(..), GObject) import Data.GI.Base.ManagedPtr (withManagedPtr) import GI.Gtk.Interfaces.TreeModel (treeModelRowDeleted, treeModelRowInserted, treeModelRowChanged, toTreeModel, TreeModel(..), IsTreeModel(..)) import GI.GObject.Objects.Object (Object(..)) import GI.Gtk.Functions (treeGetRowDragData, treeSetRowDragData) import GI.Gtk.Flags (TreeModelFlags(..)) import Control.Monad.IO.Class (MonadIO) import GI.Gtk.Structs.TreeIter (setTreeIterUserData3, setTreeIterUserData2, setTreeIterStamp, setTreeIterUserData, getTreeIterUserData, TreeIter(..)) import Data.GI.Base (get, new) import Data.GI.Base.Overloading (HasParentTypes, ParentTypes) import Data.Word (Word32) import Unsafe.Coerce (unsafeCoerce) import Foreign.Ptr (nullPtr) seqStoreIterNew :: MonadIO m => Int32 -> Int32 -> m TreeIter seqStoreIterNew s u1 = do i <- new TreeIter [] setTreeIterStamp i s setTreeIterUserData i $ unsafeCoerce u1 setTreeIterUserData2 i nullPtr setTreeIterUserData3 i nullPtr return i newtype SeqStore a = SeqStore (ManagedPtr (CustomStore (IORef (Seq a)) a)) mkSeqStore :: CustomStore (IORef (Seq a)) a -> SeqStore a mkSeqStore (CustomStore ptr) = SeqStore ptr instance HasParentTypes (SeqStore a) type instance ParentTypes (SeqStore a) = '[TreeModel] instance TypedObject (SeqStore a) where glibType = glibType @TreeModel instance GObject (SeqStore a) instance IsTypedTreeModel SeqStore -- | Create a new 'TreeModel' that contains a list of elements. seqStoreNew :: (Applicative m, MonadIO m) => [a] -> m (SeqStore a) seqStoreNew xs = seqStoreNewDND xs (Just seqStoreDefaultDragSourceIface) (Just seqStoreDefaultDragDestIface) -- | Create a new 'TreeModel' that contains a list of elements. In addition, specify two -- interfaces for drag and drop. -- seqStoreNewDND :: (Applicative m, MonadIO m) => [a] -- ^ the initial content of the model -> Maybe (DragSourceIface SeqStore a) -- ^ an optional interface for drags -> Maybe (DragDestIface SeqStore a) -- ^ an optional interface to handle drops -> m (SeqStore a) -- ^ the new model seqStoreNewDND xs mDSource mDDest = do rows <- liftIO $ newIORef (Seq.fromList xs) customStoreNew rows mkSeqStore TreeModelIface { treeModelIfaceGetFlags = return [TreeModelFlagsListOnly], treeModelIfaceGetIter = \path -> treePathGetIndices' path >>= \[n] -> readIORef rows >>= \rows -> if inRange (0, Seq.length rows - 1) (fromIntegral n) then Just <$> seqStoreIterNew 0 (fromIntegral n) else return Nothing, treeModelIfaceGetPath = \i -> do n <- seqStoreIterToIndex i treePathNewFromIndices' [fromIntegral n], treeModelIfaceGetRow = \i -> do n <- seqStoreIterToIndex i readIORef rows >>= \rows -> if inRange (0, Seq.length rows - 1) (fromIntegral n) then return (rows `Seq.index` fromIntegral n) else fail "SeqStore.getRow: iter does not refer to a valid entry", treeModelIfaceIterNext = \i -> do n <- seqStoreIterToIndex i readIORef rows >>= \rows -> if inRange (0, Seq.length rows - 1) (fromIntegral (n+1)) then Just <$> seqStoreIterNew 0 (n+1) else return Nothing, treeModelIfaceIterChildren = \index -> readIORef rows >>= \rows -> case index of Nothing | not (Seq.null rows) -> Just <$> seqStoreIterNew 0 0 _ -> return Nothing, treeModelIfaceIterHasChild = \_ -> return False, treeModelIfaceIterNChildren = \index -> readIORef rows >>= \rows -> case index of Nothing -> return $! Seq.length rows _ -> return 0, treeModelIfaceIterNthChild = \index n -> case index of Nothing -> Just <$> seqStoreIterNew 0 (fromIntegral n) _ -> return Nothing, treeModelIfaceIterParent = \_ -> return Nothing, treeModelIfaceRefNode = \_ -> return (), treeModelIfaceUnrefNode = \_ -> return () } mDSource mDDest -- | Convert a 'TreeIterRaw' to an an index into the 'SeqStore'. Note that this -- function merely extracts the second element of the 'TreeIterRaw'. seqStoreIterToIndex :: (Applicative m, MonadIO m) => TreeIter -> m Int32 seqStoreIterToIndex i = unsafeCoerce <$> getTreeIterUserData i -- | Default drag functions for 'Data.GI.Gtk.ModelView.SeqStore'. These -- functions allow the rows of the model to serve as drag source. Any row is -- allowed to be dragged and the data set in the 'SelectionDataM' object is -- set with 'treeSetRowDragData', i.e. it contains the model and the -- 'TreePath' to the row. seqStoreDefaultDragSourceIface :: DragSourceIface SeqStore row seqStoreDefaultDragSourceIface = DragSourceIface { customDragSourceRowDraggable = \_ _-> return True, customDragSourceDragDataGet = \model path sel -> treeSetRowDragData sel model path, customDragSourceDragDataDelete = \model path -> treePathGetIndices' path >>= \(dest:_) -> do liftIO $ seqStoreRemove model (fromIntegral dest) return True } -- | Default drop functions for 'Data.GI.Gtk.ModelView.SeqStore'. These -- functions accept a row and insert the row into the new location if it is -- dragged into a tree view -- that uses the same model. seqStoreDefaultDragDestIface :: DragDestIface SeqStore row seqStoreDefaultDragDestIface = DragDestIface { customDragDestRowDropPossible = \model path sel -> do dest <- treePathGetIndices' path mModelPath <- treeGetRowDragData sel case mModelPath of (True, Just model', source) -> do tm <- toTreeModel model withManagedPtr tm $ \m -> withManagedPtr model' $ \m' -> return (m==m') _ -> return False, customDragDestDragDataReceived = \model path sel -> do (dest:_) <- treePathGetIndices' path mModelPath <- treeGetRowDragData sel case mModelPath of (True, Just model', Just path) -> do (source:_) <- treePathGetIndices' path tm <- toTreeModel model withManagedPtr tm $ \m -> withManagedPtr model' $ \m' -> if m/=m' then return False else do row <- seqStoreGetValue model source seqStoreInsert model dest row return True _ -> return False } -- | Extract the value at the given index. -- seqStoreGetValue :: (Applicative m, MonadIO m) => SeqStore a -> Int32 -> m a seqStoreGetValue (SeqStore model) index = (`Seq.index` fromIntegral index) <$> liftIO (readIORef (customStoreGetPrivate (CustomStore model))) -- | Extract the value at the given index. -- seqStoreSafeGetValue :: MonadIO m => SeqStore a -> Int32 -> m (Maybe a) seqStoreSafeGetValue (SeqStore model) index' = do let index = fromIntegral index' seq <- liftIO $ readIORef (customStoreGetPrivate (CustomStore model)) return $ if index >=0 && index < Seq.length seq then Just $ seq `Seq.index` index else Nothing -- | Update the value at the given index. The index must exist. -- seqStoreSetValue :: MonadIO m => SeqStore a -> Int32 -> a -> m () seqStoreSetValue (SeqStore model) index value = do liftIO $ modifyIORef (customStoreGetPrivate (CustomStore model)) (Seq.update (fromIntegral index) value) stamp <- customStoreGetStamp (CustomStore model) path <- treePathNewFromIndices' [index] i <- seqStoreIterNew stamp (fromIntegral index) treeModelRowChanged (CustomStore model) path i -- | Extract all data from the store. -- seqStoreToList :: (Applicative m, MonadIO m) => SeqStore a -> m [a] seqStoreToList (SeqStore model) = F.toList <$> liftIO (readIORef (customStoreGetPrivate (CustomStore model))) -- | Query the number of elements in the store. seqStoreGetSize :: (Applicative m, MonadIO m) => SeqStore a -> m Int32 seqStoreGetSize (SeqStore model) = fromIntegral . Seq.length <$> liftIO (readIORef (customStoreGetPrivate (CustomStore model))) -- | Insert an element in front of the given element. The element is appended -- if the index is greater or equal to the size of the list. seqStoreInsert :: MonadIO m => SeqStore a -> Int32 -> a -> m () seqStoreInsert (SeqStore model) index value = liftIO $ do seq <- readIORef (customStoreGetPrivate (CustomStore model)) when (index >= 0) $ do let index' | fromIntegral index > Seq.length seq = Seq.length seq | otherwise = fromIntegral $ index writeIORef (customStoreGetPrivate (CustomStore model)) (insert index' value seq) stamp <- customStoreGetStamp (CustomStore model) p <- treePathNewFromIndices' [fromIntegral index'] i <- seqStoreIterNew stamp (fromIntegral index') treeModelRowInserted (CustomStore model) p i where insert :: Int -> a -> Seq a -> Seq a insert i x xs = front Seq.>< x Seq.<| back where (front, back) = Seq.splitAt i xs -- | Insert an element in front of the given element. seqStoreInsertBefore :: (Applicative m, MonadIO m) => SeqStore a -> TreeIter -> a -> m () seqStoreInsertBefore store iter value = do n <- seqStoreIterToIndex iter seqStoreInsert store n value -- | Insert an element after the given element. seqStoreInsertAfter :: (Applicative m, MonadIO m) => SeqStore a -> TreeIter -> a -> m () seqStoreInsertAfter store iter value = do n <- seqStoreIterToIndex iter seqStoreInsert store (n + 1) value -- | Prepend the element to the store. seqStorePrepend :: (Applicative m, MonadIO m) => SeqStore a -> a -> m () seqStorePrepend (SeqStore model) value = do liftIO $ modifyIORef (customStoreGetPrivate (CustomStore model)) (\seq -> value Seq.<| seq) stamp <- customStoreGetStamp (CustomStore model) p <- treePathNewFromIndices' [0] i <- seqStoreIterNew stamp 0 treeModelRowInserted (CustomStore model) p i ---- | Prepend a list to the store. Not implemented yet. --seqStorePrependList :: MonadIO m => SeqStore a -> [a] -> m () --seqStorePrependList store list = -- mapM_ (seqStoreInsert store 0) (reverse list) -- | Append an element to the store. Returns the index of the inserted -- element. seqStoreAppend :: MonadIO m => SeqStore a -> a -> m Int32 seqStoreAppend (SeqStore model) value = do index <- liftIO $ atomicModifyIORef (customStoreGetPrivate (CustomStore model)) (\seq -> (seq Seq.|> value, Seq.length seq)) stamp <- customStoreGetStamp (CustomStore model) p <- treePathNewFromIndices' [fromIntegral index] i <- seqStoreIterNew stamp (fromIntegral index) treeModelRowInserted (CustomStore model) p i return $ fromIntegral index {- seqStoreAppendList :: MonadIO m => SeqStore a -> [a] -> m () seqStoreAppendList (SeqStore model) values = do seq <- readIORef (customStoreGetPrivate model) let seq' = Seq.fromList values startIndex = Seq.length seq endIndex = startIndex + Seq.length seq' - 1 writeIORef (customStoreGetPrivate model) (seq Seq.>< seq') stamp <- customStoreGetStamp model flip mapM [startIndex..endIndex] $ \index -> treeModelRowInserted model [index] (TreeIterRaw stamp (fromIntegral index) 0 0) -} -- | Remove the element at the given index. -- seqStoreRemove :: MonadIO m => SeqStore a -> Int32 -> m () seqStoreRemove (SeqStore model) index' = liftIO $ do seq <- readIORef (customStoreGetPrivate (CustomStore model)) when (index >=0 && index < Seq.length seq) $ do writeIORef (customStoreGetPrivate (CustomStore model)) (delete index seq) p <- treePathNewFromIndices' [fromIntegral index] treeModelRowDeleted (CustomStore model) p where delete :: Int -> Seq a -> Seq a delete i xs = front Seq.>< Seq.drop 1 back where (front, back) = Seq.splitAt i xs index = fromIntegral index' -- | Empty the store. seqStoreClear :: MonadIO m => SeqStore a -> m () seqStoreClear (SeqStore model) = liftIO $ -- Since deleting rows can cause callbacks (eg due to selection changes) -- we have to make sure the model is consitent with the view at each -- intermediate step of clearing the store. Otherwise at some intermediate -- stage when the view has only been informed about some delections, the -- user might query the model expecting to find the remaining rows are there -- but find them deleted. That'd be bad. -- let loop (-1) Seq.EmptyR = return () loop n (seq Seq.:> _) = do writeIORef (customStoreGetPrivate (CustomStore model)) seq p <- treePathNewFromIndices' [fromIntegral n] treeModelRowDeleted (CustomStore model) p loop (n-1) (Seq.viewr seq) in do seq <- readIORef (customStoreGetPrivate (CustomStore model)) loop (Seq.length seq - 1) (Seq.viewr seq) ---- | Permute the rows of the store. Not yet implemented. --seqStoreReorder :: MonadIO m => SeqStore a -> [Int] -> m () --seqStoreReorder store = undefined -- ---- | Swap two rows of the store. Not yet implemented. --seqStoreSwap :: MonadIO m => SeqStore a -> Int -> Int -> m () --seqStoreSwap store = undefined -- ---- | Move the element at the first index in front of the element denoted by ---- the second index. Not yet implemented. --seqStoreMoveBefore :: MonadIO m => SeqStore a -> Int -> Int -> m () --seqStoreMoveBefore store = undefined -- ---- | Move the element at the first index past the element denoted by the ---- second index. Not yet implemented. --seqStoreMoveAfter :: MonadIO m => SeqStore a -> Int -> Int -> m () --seqStoreMoveAfter store = undefined gi-gtk-hs-0.3.9/src/Data/GI/Gtk/ModelView/TreeModel.hs0000644000000000000000000001675407346545000020316 0ustar0000000000000000-- -*-haskell-*- -- GIMP Toolkit (GTK) TreeModel -- -- Author : Axel Simon -- -- Created: 8 May 2001 -- -- Copyright (C) 1999-2016 Axel Simon, Hamish Mackenzie -- -- 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. {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MonoLocalBinds #-} -- -- | -- Stability : provisional -- Portability : portable (depends on GHC) -- -- The tree interface used by 'TreeView'. -- module Data.GI.Gtk.ModelView.TreeModel ( -- * Detail -- -- | The 'TreeModel' interface defines a generic storage object for use by the -- 'TreeView' and similar widgets. Specifically, the functions in defined here -- are used by Gtk's widgets to access the stored data. Thus, rather than -- calling these functions, an application programmer has to implement them. -- While the module "Data.GI.Gtk.ModelView.CustomStore" provides the -- necessary functions to implement the 'TreeMode' interface, it is often -- sufficient to use the wo implementations that come with gi-gtk-hs, namely are -- 'ListStore' and 'TreeStore'. -- -- The model is represented as a hierarchical tree of values. It is important -- to note that this interface only provides a way of examining a model and -- observing changes. The implementation of each individual model decides how -- and if changes are made. -- -- Two generic models are provided that implement the 'TreeModel' interface: -- the 'TreeStore' and the 'ListStore'. To use these, the developer simply -- inserts data into these models as necessary. These models provide the data -- structure as well as the 'TreeModel' interface. In fact, they implement -- other interfaces, making drag and drop and storing data trivial. -- -- A 'TreeModel' stores records of the same type. Each record is referred to -- as row, just like in a relational database. Defining how the information of -- a row is displayed can be done in two ways: If the widget displays data -- using 'Data.GI.Gtk.ModelView.CellRenderer.CellRenderer' or one of its -- derivatives, it is possible to state how a row is mapped to the attributes -- of a renderer using the -- 'Data.GI.Gtk.ModelView.CellLayout.cellLayoutSetAttributes' function. -- Some widgets do not use -- 'Data.GI.Gtk.ModelView.CellRenderer.CellRenderer's to display their -- data. In this case an extraction function can be defined that maps a row to -- one of a few basic types (like 'String's or 'Int's). This extraction -- function is associated with a 'ColumnId' using -- 'Data.GI.Gtk.ModelView.CustomStore.treeModelSetColumn'. The latter can -- be set in the widget for the property that should be set. The widget then -- uses the function 'treeModelGetValue' and the 'ColumnId' to extract the -- value from the model. As the name suggests, using 'ColumnId's creates a -- view of the data as if each row were divided into a well-defined set of -- columns, again, like a relational database. -- -- Models are accessed on a node level of granularity. There are two index -- types used to reference a particular node in a model. They are the -- 'TreePath' and the 'TreeIter'. Most of the interface consists of operations -- on a 'TreeIter'. -- -- A path is essentially a potential node. It is a location on a model that -- may or may not actually correspond to a node on a specific model. A -- 'TreePath' is in fact a synonym for a list of 'Int's and hence are easy to -- manipulate. Each number refers to the offset at that level. Thus, the path -- @[0]@ refers to the root node and the path @[2,4]@ refers to the fifth -- child of the third node. -- -- By contrast, a 'TreeIter' is a reference to a specific node on a specific -- model. It is an abstract data type filled in by the model. One can convert -- a path to an iterator by calling 'treeModelGetIter'. These iterators are -- the primary way of accessing a model and are similar to the iterators used -- by 'TextBuffer'. The model interface defines a set of operations using them -- for navigating the model. Iterators are expected to always be valid for as -- long as the model is unchanged (and doesn't emit a signal). -- -- * Class Hierarchy -- | -- @ -- | GInterface -- | +----TreeModel -- | +--------TypedTreeModel -- @ module Export, ColumnId, -- * Constructors makeColumnIdInt, makeColumnIdBool, makeColumnIdString, makeColumnIdPixbuf, invalidColumnId, -- * Methods columnIdToNumber, stringToTreePath, treeModelGetValue, treeModelGetIter ) where import Prelude () import Prelude.Compat import Data.Int (Int32) import Data.Text (Text) import Data.GI.Base.GValue (fromGValue, get_object) import Data.GI.Base.ManagedPtr (newObject) import Foreign.Ptr (Ptr) import GI.GdkPixbuf.Objects.Pixbuf (Pixbuf(..)) import GI.Gtk.Structs.TreeIter (TreeIter) import GI.Gtk.Interfaces.TreeModel as Export hiding (treeModelGetValue, treeModelGetIter) import qualified GI.Gtk.Interfaces.TreeModel as GI (treeModelGetValue, treeModelGetIter) import Data.GI.Gtk.ModelView.Types (stringToTreePath, ColumnId(..), ColumnAccess(..)) import Control.Monad.IO.Class (MonadIO) import GI.Gtk.Structs.TreePath (treePathGetDepth, TreePath(..)) import Data.Maybe (fromJust) -------------------- -- Constructors -- | Create a 'ColumnId' to extract an integer. makeColumnIdInt :: Int32 -> ColumnId row Int32 makeColumnIdInt = ColumnId fromGValue CAInt -- | Create a 'ColumnId' to extract an Boolean. makeColumnIdBool :: Int32 -> ColumnId row Bool makeColumnIdBool = ColumnId fromGValue CABool -- | Create a 'ColumnId' to extract an string. makeColumnIdString :: Int32 -> ColumnId row Text makeColumnIdString = ColumnId (\v -> fromJust <$> fromGValue v) CAString -- | Create a 'ColumnId' to extract an 'Pixbuf'. makeColumnIdPixbuf :: Int32 -> ColumnId row Pixbuf makeColumnIdPixbuf = ColumnId (\v -> (get_object v :: IO (Ptr Pixbuf)) >>= newObject Pixbuf) CAPixbuf -- | Convert a 'ColumnId' to a bare number. columnIdToNumber :: ColumnId row ty -> Int32 columnIdToNumber (ColumnId _ _ i) = i -- | The invalid 'ColumnId'. Widgets use this value if no column id has -- been set. invalidColumnId :: ColumnId row ty invalidColumnId = ColumnId (error "invalidColumnId: no GValue extractor") (error "invalidColumnId: no access type") (-1) instance Eq (ColumnId row ty) where (ColumnId _ _ i1) == (ColumnId _ _ i2) = i1==i2 instance Show (ColumnId row ty) where show (ColumnId _ _ i) = show i -------------------- -- Methods -- | Read the value of at a specific column and 'TreeIter'. -- treeModelGetValue :: IsTreeModel self => self -> TreeIter -> ColumnId row ty -- ^ @column@ - The column to lookup the value at. -> IO ty treeModelGetValue self iter (ColumnId getter _ colId) = GI.treeModelGetValue self iter colId >>= getter -- | Gets the a `TreeIter` or Nothing if the path is invalid or empty treeModelGetIter :: (MonadIO m, IsTreeModel model) => model -> TreePath -> m (Maybe TreeIter) treeModelGetIter model path = treePathGetDepth path >>= \case 0 -> return Nothing _ -> GI.treeModelGetIter model path >>= \case (True, iter) -> return $ Just iter _ -> return Nothing gi-gtk-hs-0.3.9/src/Data/GI/Gtk/ModelView/Types.hs0000644000000000000000000002070107346545000017525 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE TypeApplications #-} -- -*-haskell-*- -- GIMP Toolkit (GTK) CustomStore TreeModel -- -- Author : Duncan Coutts -- -- Created: 31 March 2006 -- -- Copyright (C) 2006-2016 Duncan Coutts, Axel Simon, Hamish Mackenzie -- -- 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. -- -- #hide -- | -- Stability : provisional -- Portability : portable (depends on GHC) -- -- Common types and classes for the ModelView modules. -- module Data.GI.Gtk.ModelView.Types ( TypedTreeModel(..), IsTypedTreeModel, toTypedTreeModel, unsafeTreeModelToGeneric, TypedTreeModelSort(..), unsafeTreeModelSortToGeneric, TypedTreeModelFilter(..), unsafeTreeModelFilterToGeneric, -- TreePath treePathNewFromIndices', treePathGetIndices', withTreePath, stringToTreePath, treeSelectionGetSelectedRows', -- Columns ColumnAccess(..), ColumnId(..), -- Storing the model in a ComboBox comboQuark, equalManagedPtr ) where import Prelude () import Prelude.Compat import GHC.Exts (unsafeCoerce#) import Data.Char ( isDigit ) import Data.Word (Word32) import Data.Int (Int32) import Data.Text (Text) import qualified Data.Text as T (unpack) import Data.Coerce (coerce) import Control.Monad ( liftM ) import Control.Monad.IO.Class (MonadIO(..)) import Control.Exception (catch) import Foreign.Storable (Storable(..)) import Foreign.Ptr (Ptr, castPtr, plusPtr, minusPtr, nullPtr) import Foreign.C.Types (CInt(..)) import Foreign.Marshal.Alloc (alloca) import Foreign.Marshal.Utils (toBool) import System.IO.Unsafe (unsafePerformIO) import Foreign.Marshal.Utils (with) import Data.GI.Base.BasicTypes (ManagedPtr(..), ManagedPtrNewtype, UnexpectedNullPointerReturn, TypedObject(..), GObject) import Data.GI.Base.ManagedPtr (withManagedPtr) import Data.GI.Base.Overloading (HasParentTypes, ParentTypes) import Data.GI.Base.GValue (GValue) import GI.GObject.Objects.Object (Object(..)) import GI.Gtk.Interfaces.TreeModel (TreeModel, IsTreeModel(..)) import GI.Gtk.Objects.TreeModelSort (TreeModelSort, IsTreeModelSort(..)) import GI.Gtk.Objects.TreeSelection (IsTreeSelection, treeSelectionCountSelectedRows, treeSelectionGetSelectedRows) import GI.Gtk.Objects.TreeModelFilter (TreeModelFilter) import GI.Gtk.Interfaces.TreeSortable (TreeSortable, IsTreeSortable(..)) import GI.GLib.Functions (quarkFromString) import GI.GdkPixbuf.Objects.Pixbuf (Pixbuf(..)) import GI.Gtk.Structs.TreeIter (TreeIter(..), treeIterCopy) import GI.Gtk.Structs.TreePath (TreePath(..), treePathGetIndices, treePathAppendIndex, treePathNew, treePathGetDepth) import Data.GI.Base.Constructible (Constructible(..)) import Data.GI.Base.Attributes (AttrOp(..)) import Unsafe.Coerce (unsafeCoerce) import Data.GI.Base (set, get) import Data.IORef (newIORef) equalManagedPtr :: ManagedPtrNewtype a => a -> a -> Bool equalManagedPtr a b = managedForeignPtr (coerce a :: ManagedPtr ()) == managedForeignPtr (coerce b :: ManagedPtr ()) newtype TypedTreeModel row = TypedTreeModel (ManagedPtr (TypedTreeModel row)) class IsTypedTreeModel model where dummy :: model a -> a dummy _ = error "not used" -- this is to get the right kind for model :: * -> * -- TODO: when haddock is fixed we can use an explicit kind annotation toTypedTreeModel :: IsTypedTreeModel model => model row -> TypedTreeModel row toTypedTreeModel = unsafeCoerce# unsafeTreeModelToGeneric :: TreeModel -> model row unsafeTreeModelToGeneric = unsafeCoerce# instance IsTypedTreeModel TypedTreeModel newtype TypedTreeModelSort row = TypedTreeModelSort (ManagedPtr (TypedTreeModelSort row)) instance HasParentTypes (TypedTreeModelSort row) type instance ParentTypes (TypedTreeModelSort row) = '[TreeSortable, TreeModel, TreeModelSort] instance TypedObject (TypedTreeModelSort row) where glibType = glibType @TreeModelSort instance GObject (TypedTreeModelSort row) unsafeTreeModelSortToGeneric :: TreeModelSort -> TypedTreeModelSort row unsafeTreeModelSortToGeneric = unsafeCoerce# instance IsTypedTreeModel TypedTreeModelSort newtype TypedTreeModelFilter row = TypedTreeModelFilter (ManagedPtr (TypedTreeModelFilter row)) unsafeTreeModelFilterToGeneric :: TreeModelFilter -> TypedTreeModelFilter row unsafeTreeModelFilterToGeneric = unsafeCoerce# instance IsTypedTreeModel TypedTreeModelFilter -- | TreePath is a list of indices to specify a subtree or node in a -- 'Graphics.UI.Gtk.ModelView.TreeModel.TreeModel'. The node that correspond -- to a given 'TreePath' might change if nodes are removed or added and a -- 'TreePath' may refer to a different or even non-existent node after a -- modification of the model. In contrast, a 'TreeIter' is a more compact -- representation of a 'TreePath' which becomes invalid after each -- modification of the underlying model. An intelligent index that is adjusted -- with each update of the model to point to the same node (whenever possible) -- is 'Graphics.UI.Gtk.ModelView.TreeRowReference.TreeRowReference'. -- treePathNewFromIndices' :: MonadIO m => [Int32] -> m TreePath treePathNewFromIndices' [] = treePathNew treePathNewFromIndices' x = do path <- treePathNew mapM_ (treePathAppendIndex path) x return path -- TODO (once every one has Gtk+ 3.12) use treePathNewFromIndices x treePathGetIndices' :: MonadIO m => TreePath -> m [Int32] treePathGetIndices' path = treePathGetDepth path >>= \case 0 -> return [] _ -> do indices <- treePathGetIndices path case indices of Just ixs -> return ixs Nothing -> return [] withTreePath :: MonadIO m => [Int32] -> (TreePath -> m a) -> m a withTreePath tp act = treePathNewFromIndices' tp >>= act --maybeWithTreePath :: MonadIO m => Maybe [Int32] -> (TreePath -> m a) -> m a --maybeWithTreePath mbTp act = maybe (act (TreePath nullManagedPtr)) (`withTreePath` act) mbTp treeSelectionGetSelectedRows' :: (MonadIO m, IsTreeSelection sel) => sel -> m [TreePath] treeSelectionGetSelectedRows' sel = treeSelectionCountSelectedRows sel >>= \case 0 -> return [] _ -> liftIO $ (fst <$> treeSelectionGetSelectedRows sel) `catch` (\(_::UnexpectedNullPointerReturn) -> return []) -- | Convert a comma or colon separated string into a 'TreePath'. Any -- non-digit characters are assumed to separate indices, thus, the function -- always is always successful. stringToTreePath :: Text -> [Int32] stringToTreePath = stringToTreePath' . T.unpack where stringToTreePath' "" = [] stringToTreePath' path = getNum 0 (dropWhile (not . isDigit) path) getNum acc ('0':xs) = getNum (10*acc) xs getNum acc ('1':xs) = getNum (10*acc+1) xs getNum acc ('2':xs) = getNum (10*acc+2) xs getNum acc ('3':xs) = getNum (10*acc+3) xs getNum acc ('4':xs) = getNum (10*acc+4) xs getNum acc ('5':xs) = getNum (10*acc+5) xs getNum acc ('6':xs) = getNum (10*acc+6) xs getNum acc ('7':xs) = getNum (10*acc+7) xs getNum acc ('8':xs) = getNum (10*acc+8) xs getNum acc ('9':xs) = getNum (10*acc+9) xs getNum acc xs = acc:stringToTreePath' (dropWhile (not . isDigit) xs) -- | Accessing a row for a specific value. Used for 'ColumnMap'. data ColumnAccess row where CAInvalid :: ColumnAccess row CAInt :: (row -> Int32) -> ColumnAccess row CABool :: (row -> Bool) -> ColumnAccess row CAString :: (row -> Text) -> ColumnAccess row CAPixbuf :: (row -> Pixbuf) -> ColumnAccess row -- | The type of a tree column. data ColumnId row ty = ColumnId (GValue -> IO ty) ((row -> ty) -> ColumnAccess row) Int32 -- it shouldn't matter if the following function is actually inlined {-# NOINLINE comboQuark #-} comboQuark :: Word32 comboQuark = unsafePerformIO $ quarkFromString (Just "comboBoxHaskellStringModelQuark") gi-gtk-hs-0.3.9/src/Data/GI/Gtk/Threading.hs0000644000000000000000000001351407346545000016437 0ustar0000000000000000-- -*-haskell-*- -- -- Author : Brandon Sloane -- -- Created: 16 August 2017 -- -- Copyright (C) 2017 Brandon Sloane -- -- 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. -- -- | -- Stability : provisional -- Portability : portable (depends on GHC) -- -- Utility functions for threading -- module Data.GI.Gtk.Threading ( -- | Utility functions to run IO actions on the GUI thread. You must call -- 'Data.GI.Gtk.Threading.setGUIThread' or 'Data.GI.Gtk.Threading.setCurrentThreadAsGUIThread' -- before using the synchronous options, or you risk deadlocking. -- -- Note that the notion of "Thread" used by this module corresponds to operating system threads, not Haskell threads. -- A single operating system thread may run multiple Haskell threads, and a Haskell thread may migrate between operating system threads. -- In order for this nothing of "Thread" to make sense to a Haskell program, we must be working in a bound Haskell thread, which is tied to a single operating system thread. -- Haskell's main function is automatically bound, and the postGUI functions will create a new bound thread if nessasary. setGUIThread , getGUIThread , setCurrentThreadAsGUIThread , postGUISyncWithPriority , postGUISync , postGUIASyncWithPriority , postGUIASync , compareThreads , isGUIThread , module GI.GLib --threadSelf and Thread ) where import Control.Concurrent import Control.Concurrent.MVar import Data.Int (Int32) import System.IO.Unsafe (unsafePerformIO) import System.IO (stderr, hPutStrLn) import GI.Gdk (threadsAddIdle) import GI.GLib.Constants import GI.GLib (threadSelf, Thread(..)) import Data.GI.Base.ManagedPtr guiThread :: MVar (Maybe Thread) {-# NOINLINE guiThread #-} guiThread = unsafePerformIO $ newMVar Nothing -- | Inform gi-gtk-hs what thread is running the gtk main loop. setGUIThread :: Thread -> IO () setGUIThread t = swapMVar guiThread (Just t) >> return () -- | Inform gi-gtk-hs that the current thread is, or will be, running the gtk main loop. -- -- Equivalent to @'GI.GLib.threadSelf' >>= 'Data.GI.Gtk.Threading.setGUIThread'@ setCurrentThreadAsGUIThread :: IO () setCurrentThreadAsGUIThread = threadSelf >>= setGUIThread -- | Get the Thread that is running the Gtk main loop, if it has been set. getGUIThread :: IO (Maybe Thread) getGUIThread = readMVar guiThread -- | Queue an action to be run in the GTK event loop. -- If called from the same process as the event loop, this runs the action directly. -- Otherwise, this queues it in GTK's event loop and blocks until the action is complete -- -- You must call 'Data.GI.Gtk.Threading.setGUIThread' or 'Data.GI.Gtk.Threading.setCurrentThreadAsGUIThread' before this. -- -- Priority is typically between 'GI.GLib.Constants.PRIORITY_HIGH_IDLE' (100) and 'GI.GLib.Constants.PRIORITY_DEFAULT_IDLE' (200) postGUISyncWithPriority :: Int32 -> IO a -> IO a postGUISyncWithPriority priority action = runInBoundThread $ do b <- isGUIThread if b then action else run where run = do ans <- newEmptyMVar threadsAddIdle priority $ action >>= putMVar ans >> return False takeMVar ans -- | Queue an action to be run in the GTK event loop. -- If called from the same process as the event loop, this runs the action directly. -- Otherwise, this queues it in GTK's event loop and blocks until the action is complete -- -- You must call 'Data.GI.Gtk.Threading.setGUIThread' or 'Data.GI.Gtk.Threading.setCurrentThreadAsGUIThread' before this. -- -- Equivalent to @'Data.GI.Gtk.Threading.postGUISyncWithPriority' 'GI.GLib.Constants.PRIORITY_DEFAULT_IDLE'@ postGUISync :: IO a -> IO a postGUISync = postGUISyncWithPriority PRIORITY_DEFAULT_IDLE -- | Queue an action to be run in the GTK event loop. -- This function queues the event regardless of what process it is called from, and returns immidietly. -- -- Priority is typically between 'GI.GLib.Constants.PRIORITY_HIGH_IDLE' (100) and 'GI.GLib.Constants.PRIORITY_DEFAULT_IDLE' (200) postGUIASyncWithPriority :: Int32 -> IO () -> IO () postGUIASyncWithPriority priority action = threadsAddIdle priority (action >> return False) >> return () -- | Queue an action to be run in the GTK event loop. -- This function queues the event regardless of what process it is called from, and returns immidietly. -- -- Equivalent to @'Data.GI.Gtk.Threading.postGUIASyncWithPriority' 'GI.GLib.Constants.PRIORITY_DEFAULT_IDLE'@ postGUIASync :: IO () -> IO () postGUIASync = postGUIASyncWithPriority PRIORITY_DEFAULT_IDLE -- | Test if two 'GI.GLib.Structs.Thread.Thread's refer to the same OS thread. -- A 'GI.GLib.Structs.Thread.Thread' can be gotten from 'GI.GLib.Structs.Thread.threadSelf'. -- Note that 'GI.GLib.Structs.Thread.threadSelf' only makes sense from a bound thread. compareThreads :: Thread -> Thread -> IO Bool compareThreads (Thread mptr1) (Thread mptr2) = withManagedPtr mptr1 $ \ptr1 -> withManagedPtr mptr2 $ \ptr2 -> return $ ptr1 == ptr2 -- | Check if the current thread is the Gtk gui thread. -- -- You must call 'Data.GI.Gtk.Threading.setGUIThread' or 'Data.GI.Gtk.Threading.setCurrentThreadAsGUIThread' before this. -- This only makes sense when called from a bound thread. isGUIThread :: IO Bool isGUIThread = do guiThread <- getGUIThread case guiThread of Nothing -> hPutStrLn stderr "WARNING Data.GI.Gtk.Threading Calling isGUIThread before setGUIThread" >> return False Just t1 -> threadSelf >>= compareThreads t1