diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,502 @@ + GNU LESSER GENERAL PUBLIC LICENSE + Version 2.1, February 1999 + + Copyright (C) 1991, 1999 Free Software Foundation, Inc. + 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + +[This is the first released version of the Lesser GPL. It also counts + as the successor of the GNU Library Public License, version 2, hence + the version number 2.1.] + + Preamble + + The licenses for most software are designed to take away your +freedom to share and change it. By contrast, the GNU General Public +Licenses are intended to guarantee your freedom to share and change +free software--to make sure the software is free for all its users. + + This license, the Lesser General Public License, applies to some +specially designated software packages--typically libraries--of the +Free Software Foundation and other authors who decide to use it. You +can use it too, but we suggest you first think carefully about whether +this license or the ordinary General Public License is the better +strategy to use in any particular case, based on the explanations below. + + When we speak of free software, we are referring to freedom of use, +not price. Our General Public Licenses are designed to make sure that +you have the freedom to distribute copies of free software (and charge +for this service if you wish); that you receive source code or can get +it if you want it; that you can change the software and use pieces of +it in new free programs; and that you are informed that you can do +these things. + + To protect your rights, we need to make restrictions that forbid +distributors to deny you these rights or to ask you to surrender these +rights. These restrictions translate to certain responsibilities for +you if you distribute copies of the library or if you modify it. + + For example, if you distribute copies of the library, whether gratis +or for a fee, you must give the recipients all the rights that we gave +you. You must make sure that they, too, receive or can get the source +code. If you link other code with the library, you must provide +complete object files to the recipients, so that they can relink them +with the library after making changes to the library and recompiling +it. And you must show them these terms so they know their rights. + + We protect your rights with a two-step method: (1) we copyright the +library, and (2) we offer you this license, which gives you legal +permission to copy, distribute and/or modify the library. + + To protect each distributor, we want to make it very clear that +there is no warranty for the free library. Also, if the library is +modified by someone else and passed on, the recipients should know +that what they have is not the original version, so that the original +author's reputation will not be affected by problems that might be +introduced by others. + + Finally, software patents pose a constant threat to the existence of +any free program. We wish to make sure that a company cannot +effectively restrict the users of a free program by obtaining a +restrictive license from a patent holder. Therefore, we insist that +any patent license obtained for a version of the library must be +consistent with the full freedom of use specified in this license. + + Most GNU software, including some libraries, is covered by the +ordinary GNU General Public License. This license, the GNU Lesser +General Public License, applies to certain designated libraries, and +is quite different from the ordinary General Public License. We use +this license for certain libraries in order to permit linking those +libraries into non-free programs. + + When a program is linked with a library, whether statically or using +a shared library, the combination of the two is legally speaking a +combined work, a derivative of the original library. The ordinary +General Public License therefore permits such linking only if the +entire combination fits its criteria of freedom. The Lesser General +Public License permits more lax criteria for linking other code with +the library. + + We call this license the "Lesser" General Public License because it +does Less to protect the user's freedom than the ordinary General +Public License. It also provides other free software developers Less +of an advantage over competing non-free programs. These disadvantages +are the reason we use the ordinary General Public License for many +libraries. However, the Lesser license provides advantages in certain +special circumstances. + + For example, on rare occasions, there may be a special need to +encourage the widest possible use of a certain library, so that it becomes +a de-facto standard. To achieve this, non-free programs must be +allowed to use the library. A more frequent case is that a free +library does the same job as widely used non-free libraries. In this +case, there is little to gain by limiting the free library to free +software only, so we use the Lesser General Public License. + + In other cases, permission to use a particular library in non-free +programs enables a greater number of people to use a large body of +free software. For example, permission to use the GNU C Library in +non-free programs enables many more people to use the whole GNU +operating system, as well as its variant, the GNU/Linux operating +system. + + Although the Lesser General Public License is Less protective of the +users' freedom, it does ensure that the user of a program that is +linked with the Library has the freedom and the wherewithal to run +that program using a modified version of the Library. + + The precise terms and conditions for copying, distribution and +modification follow. Pay close attention to the difference between a +"work based on the library" and a "work that uses the library". The +former contains code derived from the library, whereas the latter must +be combined with the library in order to run. + + GNU LESSER GENERAL PUBLIC LICENSE + TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION + + 0. This License Agreement applies to any software library or other +program which contains a notice placed by the copyright holder or +other authorized party saying it may be distributed under the terms of +this Lesser General Public License (also called "this License"). +Each licensee is addressed as "you". + + A "library" means a collection of software functions and/or data +prepared so as to be conveniently linked with application programs +(which use some of those functions and data) to form executables. + + The "Library", below, refers to any such software library or work +which has been distributed under these terms. A "work based on the +Library" means either the Library or any derivative work under +copyright law: that is to say, a work containing the Library or a +portion of it, either verbatim or with modifications and/or translated +straightforwardly into another language. (Hereinafter, translation is +included without limitation in the term "modification".) + + "Source code" for a work means the preferred form of the work for +making modifications to it. For a library, complete source code means +all the source code for all modules it contains, plus any associated +interface definition files, plus the scripts used to control compilation +and installation of the library. + + Activities other than copying, distribution and modification are not +covered by this License; they are outside its scope. The act of +running a program using the Library is not restricted, and output from +such a program is covered only if its contents constitute a work based +on the Library (independent of the use of the Library in a tool for +writing it). Whether that is true depends on what the Library does +and what the program that uses the Library does. + + 1. You may copy and distribute verbatim copies of the Library's +complete source code as you receive it, in any medium, provided that +you conspicuously and appropriately publish on each copy an +appropriate copyright notice and disclaimer of warranty; keep intact +all the notices that refer to this License and to the absence of any +warranty; and distribute a copy of this License along with the +Library. + + You may charge a fee for the physical act of transferring a copy, +and you may at your option offer warranty protection in exchange for a +fee. + + 2. You may modify your copy or copies of the Library or any portion +of it, thus forming a work based on the Library, and copy and +distribute such modifications or work under the terms of Section 1 +above, provided that you also meet all of these conditions: + + a) The modified work must itself be a software library. + + b) You must cause the files modified to carry prominent notices + stating that you changed the files and the date of any change. + + c) You must cause the whole of the work to be licensed at no + charge to all third parties under the terms of this License. + + d) If a facility in the modified Library refers to a function or a + table of data to be supplied by an application program that uses + the facility, other than as an argument passed when the facility + is invoked, then you must make a good faith effort to ensure that, + in the event an application does not supply such function or + table, the facility still operates, and performs whatever part of + its purpose remains meaningful. + + (For example, a function in a library to compute square roots has + a purpose that is entirely well-defined independent of the + application. Therefore, Subsection 2d requires that any + application-supplied function or table used by this function must + be optional: if the application does not supply it, the square + root function must still compute square roots.) + +These requirements apply to the modified work as a whole. If +identifiable sections of that work are not derived from the Library, +and can be reasonably considered independent and separate works in +themselves, then this License, and its terms, do not apply to those +sections when you distribute them as separate works. But when you +distribute the same sections as part of a whole which is a work based +on the Library, the distribution of the whole must be on the terms of +this License, whose permissions for other licensees extend to the +entire whole, and thus to each and every part regardless of who wrote +it. + +Thus, it is not the intent of this section to claim rights or contest +your rights to work written entirely by you; rather, the intent is to +exercise the right to control the distribution of derivative or +collective works based on the Library. + +In addition, mere aggregation of another work not based on the Library +with the Library (or with a work based on the Library) on a volume of +a storage or distribution medium does not bring the other work under +the scope of this License. + + 3. You may opt to apply the terms of the ordinary GNU General Public +License instead of this License to a given copy of the Library. To do +this, you must alter all the notices that refer to this License, so +that they refer to the ordinary GNU General Public License, version 2, +instead of to this License. (If a newer version than version 2 of the +ordinary GNU General Public License has appeared, then you can specify +that version instead if you wish.) Do not make any other change in +these notices. + + Once this change is made in a given copy, it is irreversible for +that copy, so the ordinary GNU General Public License applies to all +subsequent copies and derivative works made from that copy. + + This option is useful when you wish to copy part of the code of +the Library into a program that is not a library. + + 4. You may copy and distribute the Library (or a portion or +derivative of it, under Section 2) in object code or executable form +under the terms of Sections 1 and 2 above provided that you accompany +it with the complete corresponding machine-readable source code, which +must be distributed under the terms of Sections 1 and 2 above on a +medium customarily used for software interchange. + + If distribution of object code is made by offering access to copy +from a designated place, then offering equivalent access to copy the +source code from the same place satisfies the requirement to +distribute the source code, even though third parties are not +compelled to copy the source along with the object code. + + 5. A program that contains no derivative of any portion of the +Library, but is designed to work with the Library by being compiled or +linked with it, is called a "work that uses the Library". Such a +work, in isolation, is not a derivative work of the Library, and +therefore falls outside the scope of this License. + + However, linking a "work that uses the Library" with the Library +creates an executable that is a derivative of the Library (because it +contains portions of the Library), rather than a "work that uses the +library". The executable is therefore covered by this License. +Section 6 states terms for distribution of such executables. + + When a "work that uses the Library" uses material from a header file +that is part of the Library, the object code for the work may be a +derivative work of the Library even though the source code is not. +Whether this is true is especially significant if the work can be +linked without the Library, or if the work is itself a library. The +threshold for this to be true is not precisely defined by law. + + If such an object file uses only numerical parameters, data +structure layouts and accessors, and small macros and small inline +functions (ten lines or less in length), then the use of the object +file is unrestricted, regardless of whether it is legally a derivative +work. (Executables containing this object code plus portions of the +Library will still fall under Section 6.) + + Otherwise, if the work is a derivative of the Library, you may +distribute the object code for the work under the terms of Section 6. +Any executables containing that work also fall under Section 6, +whether or not they are linked directly with the Library itself. + + 6. As an exception to the Sections above, you may also combine or +link a "work that uses the Library" with the Library to produce a +work containing portions of the Library, and distribute that work +under terms of your choice, provided that the terms permit +modification of the work for the customer's own use and reverse +engineering for debugging such modifications. + + You must give prominent notice with each copy of the work that the +Library is used in it and that the Library and its use are covered by +this License. You must supply a copy of this License. If the work +during execution displays copyright notices, you must include the +copyright notice for the Library among them, as well as a reference +directing the user to the copy of this License. Also, you must do one +of these things: + + a) Accompany the work with the complete corresponding + machine-readable source code for the Library including whatever + changes were used in the work (which must be distributed under + Sections 1 and 2 above); and, if the work is an executable linked + with the Library, with the complete machine-readable "work that + uses the Library", as object code and/or source code, so that the + user can modify the Library and then relink to produce a modified + executable containing the modified Library. (It is understood + that the user who changes the contents of definitions files in the + Library will not necessarily be able to recompile the application + to use the modified definitions.) + + b) Use a suitable shared library mechanism for linking with the + Library. A suitable mechanism is one that (1) uses at run time a + copy of the library already present on the user's computer system, + rather than copying library functions into the executable, and (2) + will operate properly with a modified version of the library, if + the user installs one, as long as the modified version is + interface-compatible with the version that the work was made with. + + c) Accompany the work with a written offer, valid for at + least three years, to give the same user the materials + specified in Subsection 6a, above, for a charge no more + than the cost of performing this distribution. + + d) If distribution of the work is made by offering access to copy + from a designated place, offer equivalent access to copy the above + specified materials from the same place. + + e) Verify that the user has already received a copy of these + materials or that you have already sent this user a copy. + + For an executable, the required form of the "work that uses the +Library" must include any data and utility programs needed for +reproducing the executable from it. However, as a special exception, +the materials to be distributed need not include anything that is +normally distributed (in either source or binary form) with the major +components (compiler, kernel, and so on) of the operating system on +which the executable runs, unless that component itself accompanies +the executable. + + It may happen that this requirement contradicts the license +restrictions of other proprietary libraries that do not normally +accompany the operating system. Such a contradiction means you cannot +use both them and the Library together in an executable that you +distribute. + + 7. You may place library facilities that are a work based on the +Library side-by-side in a single library together with other library +facilities not covered by this License, and distribute such a combined +library, provided that the separate distribution of the work based on +the Library and of the other library facilities is otherwise +permitted, and provided that you do these two things: + + a) Accompany the combined library with a copy of the same work + based on the Library, uncombined with any other library + facilities. This must be distributed under the terms of the + Sections above. + + b) Give prominent notice with the combined library of the fact + that part of it is a work based on the Library, and explaining + where to find the accompanying uncombined form of the same work. + + 8. You may not copy, modify, sublicense, link with, or distribute +the Library except as expressly provided under this License. Any +attempt otherwise to copy, modify, sublicense, link with, or +distribute the Library is void, and will automatically terminate your +rights under this License. However, parties who have received copies, +or rights, from you under this License will not have their licenses +terminated so long as such parties remain in full compliance. + + 9. You are not required to accept this License, since you have not +signed it. However, nothing else grants you permission to modify or +distribute the Library or its derivative works. These actions are +prohibited by law if you do not accept this License. Therefore, by +modifying or distributing the Library (or any work based on the +Library), you indicate your acceptance of this License to do so, and +all its terms and conditions for copying, distributing or modifying +the Library or works based on it. + + 10. Each time you redistribute the Library (or any work based on the +Library), the recipient automatically receives a license from the +original licensor to copy, distribute, link with or modify the Library +subject to these terms and conditions. You may not impose any further +restrictions on the recipients' exercise of the rights granted herein. +You are not responsible for enforcing compliance by third parties with +this License. + + 11. If, as a consequence of a court judgment or allegation of patent +infringement or for any other reason (not limited to patent issues), +conditions are imposed on you (whether by court order, agreement or +otherwise) that contradict the conditions of this License, they do not +excuse you from the conditions of this License. If you cannot +distribute so as to satisfy simultaneously your obligations under this +License and any other pertinent obligations, then as a consequence you +may not distribute the Library at all. For example, if a patent +license would not permit royalty-free redistribution of the Library by +all those who receive copies directly or indirectly through you, then +the only way you could satisfy both it and this License would be to +refrain entirely from distribution of the Library. + +If any portion of this section is held invalid or unenforceable under any +particular circumstance, the balance of the section is intended to apply, +and the section as a whole is intended to apply in other circumstances. + +It is not the purpose of this section to induce you to infringe any +patents or other property right claims or to contest validity of any +such claims; this section has the sole purpose of protecting the +integrity of the free software distribution system which is +implemented by public license practices. Many people have made +generous contributions to the wide range of software distributed +through that system in reliance on consistent application of that +system; it is up to the author/donor to decide if he or she is willing +to distribute software through any other system and a licensee cannot +impose that choice. + +This section is intended to make thoroughly clear what is believed to +be a consequence of the rest of this License. + + 12. If the distribution and/or use of the Library is restricted in +certain countries either by patents or by copyrighted interfaces, the +original copyright holder who places the Library under this License may add +an explicit geographical distribution limitation excluding those countries, +so that distribution is permitted only in or among countries not thus +excluded. In such case, this License incorporates the limitation as if +written in the body of this License. + + 13. The Free Software Foundation may publish revised and/or new +versions of the Lesser General Public License from time to time. +Such new versions will be similar in spirit to the present version, +but may differ in detail to address new problems or concerns. + +Each version is given a distinguishing version number. If the Library +specifies a version number of this License which applies to it and +"any later version", you have the option of following the terms and +conditions either of that version or of any later version published by +the Free Software Foundation. If the Library does not specify a +license version number, you may choose any version ever published by +the Free Software Foundation. + + 14. If you wish to incorporate parts of the Library into other free +programs whose distribution conditions are incompatible with these, +write to the author to ask for permission. For software which is +copyrighted by the Free Software Foundation, write to the Free +Software Foundation; we sometimes make exceptions for this. Our +decision will be guided by the two goals of preserving the free status +of all derivatives of our free software and of promoting the sharing +and reuse of software generally. + + NO WARRANTY + + 15. BECAUSE THE LIBRARY IS LICENSED FREE OF CHARGE, THERE IS NO +WARRANTY FOR THE LIBRARY, TO THE EXTENT PERMITTED BY APPLICABLE LAW. +EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR +OTHER PARTIES PROVIDE THE LIBRARY "AS IS" WITHOUT WARRANTY OF ANY +KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE +LIBRARY IS WITH YOU. SHOULD THE LIBRARY PROVE DEFECTIVE, YOU ASSUME +THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. + + 16. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN +WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY +AND/OR REDISTRIBUTE THE LIBRARY AS PERMITTED ABOVE, BE LIABLE TO YOU +FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR +CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE +LIBRARY (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING +RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A +FAILURE OF THE LIBRARY TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF +SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH +DAMAGES. + + END OF TERMS AND CONDITIONS + + How to Apply These Terms to Your New Libraries + + If you develop a new library, and you want it to be of the greatest +possible use to the public, we recommend making it free software that +everyone can redistribute and change. You can do so by permitting +redistribution under these terms (or, alternatively, under the terms of the +ordinary General Public License). + + To apply these terms, attach the following notices to the library. It is +safest to attach them to the start of each source file to most effectively +convey the exclusion of warranty; and each file should have at least the +"copyright" line and a pointer to where the full notice is found. + + + Copyright (C) + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Lesser General Public + License as published by the Free Software Foundation; either + version 2.1 of the License, or (at your option) any later version. + + This library is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General Public + License along with this library; if not, write to the Free Software + Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +Also add information on how to contact you by electronic and paper mail. + +You should also get your employer (if you work as a programmer) or your +school, if any, to sign a "copyright disclaimer" for the library, if +necessary. Here is a sample; alter the names: + + Yoyodyne, Inc., hereby disclaims all copyright interest in the + library `Frob' (a library for tweaking knobs) written by James Random Hacker. + + , 1 April 1990 + Ty Coon, President of Vice + +That's all there is to it! diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/cbits/Gtk2HsStore.c b/cbits/Gtk2HsStore.c new file mode 100644 --- /dev/null +++ b/cbits/Gtk2HsStore.c @@ -0,0 +1,801 @@ +#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); +} diff --git a/cbits/quartzfix.c b/cbits/quartzfix.c new file mode 100644 --- /dev/null +++ b/cbits/quartzfix.c @@ -0,0 +1,18 @@ +#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"); +} + diff --git a/gi-gtk-hs.cabal b/gi-gtk-hs.cabal new file mode 100644 --- /dev/null +++ b/gi-gtk-hs.cabal @@ -0,0 +1,49 @@ +name: gi-gtk-hs +version: 0.2.0.0 +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/gi-gtk-hs +license: LGPL-2.1 +license-file: LICENSE +author: Jonas Platte, + Duncan Coutts, + Axel Simon, + Hamish Mackenzie +maintainer: mail@jonasplatte.de +category: Graphics +build-type: Simple +cabal-version: >=1.10 + +library + exposed-modules: Data.GI.Gtk, + Data.GI.Gtk.BuildFn + 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.7 && <4.10, + base-compat >=0.9.0 && <0.10, + mtl >=2.1 && <2.3, + transformers >=0.3.0.0 && <0.6, + containers >=0.5.5.1 && <0.6, + text >=1.2 && <1.3, + haskell-gi-base >=0.17 && <0.18, + gi-glib >=2.0.2 && <2.1, + gi-gobject >=2.0.2 && <2.1, + gi-gdk >=3.0.2 && <3.1, + gi-gtk >=3.0.2 && <3.1, + gi-gdkpixbuf >=2.0.2 && <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 + diff --git a/src/Data/GI/Gtk.hs b/src/Data/GI/Gtk.hs new file mode 100644 --- /dev/null +++ b/src/Data/GI/Gtk.hs @@ -0,0 +1,20 @@ +module 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 diff --git a/src/Data/GI/Gtk/BuildFn.hs b/src/Data/GI/Gtk/BuildFn.hs new file mode 100644 --- /dev/null +++ b/src/Data/GI/Gtk/BuildFn.hs @@ -0,0 +1,60 @@ +{-| +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) +import Data.GI.Base.BasicTypes (nullToNothing) +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 => (ForeignPtr a -> a) -> T.Text -> BuildFn a +getObject ctor name = do + builder <- ask + Just obj <- nullToNothing $ builderGetObject builder name + liftIO $ fromJust <$> castTo ctor obj diff --git a/src/Data/GI/Gtk/ComboBox.hs b/src/Data/GI/Gtk/ComboBox.hs new file mode 100644 --- /dev/null +++ b/src/Data/GI/Gtk/ComboBox.hs @@ -0,0 +1,246 @@ +-- -*-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. +-- +-- | +-- 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, cellLayoutSetAttributeFunc, cellLayoutGetCells) +import GI.Gtk.Objects.CellRendererText (CellRendererText(..), cellRendererTextNew, setCellRendererTextText) +import GI.GObject.Objects.Object (Object, ObjectK, 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 + let obj' = unsafeManagedPtrCastPtr obj + g_object_set_qdata obj' (fromIntegral attr) nullPtr + touchManagedPtr obj +objectSetAttribute obj attr (Just val) = liftIO $ do + sPtr <- newStablePtr val + let 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 + let 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, ComboBoxK 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 + cellLayoutSetAttributeFunc layout ren store (\iter -> do + customStoreGetRow store iter >>= setCellRendererTextText ren) + objectSetAttribute combo comboQuark (Just store) + return store + +-- | Retrieve the model that was created with 'comboBoxSetModelText'. +-- +comboBoxGetModelText :: (MonadIO m, ComboBoxK self) => self -> m (SeqStore Text) +comboBoxGetModelText self = do + (Just store) <- objectGetAttributeUnsafe self comboQuark + return store + +-- | 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, ComboBoxK 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, ComboBoxK 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, ComboBoxK 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, ComboBoxK 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, ComboBoxK 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) + diff --git a/src/Data/GI/Gtk/ModelView/CellLayout.hs b/src/Data/GI/Gtk/ModelView/CellLayout.hs new file mode 100644 --- /dev/null +++ b/src/Data/GI/Gtk/ModelView/CellLayout.hs @@ -0,0 +1,188 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +-- -*-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 + , cellLayoutSetAttributeFunc + , 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 + (treeIterStamp, treeIterUserData3, treeIterUserData2, + treeIterUserData, TreeIter(..)) +import GI.Gtk.Objects.CellRenderer (CellRendererK, 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) + +-------------------- +-- 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, CellLayoutK self, CellRendererK 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, + CellLayoutK self, + CellRendererK cell, + TreeModelK (model row), + TypedTreeModelK 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 = + cellLayoutSetAttributeFunc self cell model $ \iter -> do + row <- customStoreGetRow model iter + set cell (attributes 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. +-- +cellLayoutSetAttributeFunc :: (MonadIO m, + CellLayoutK self, + CellRendererK cell, + TreeModelK 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 () +cellLayoutSetAttributeFunc self cell model func = liftIO $ do + cellLayoutSetCellDataFunc self cell . Just $ \_ (CellRenderer cellPtr') model' iter -> do + iter <- convertIterFromParentToChildModel iter model' =<< toTreeModel model + CellRenderer cellPtr <- toCellRenderer cell + if cellPtr /= 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 modelPtr==parentModelPtr + then return iter + else + castTo TreeModelFilter parentModel >>= \case + Just tmFilter -> do + childIter <- treeModelFilterConvertIterToChildIter tmFilter iter + Just child@(TreeModel childPtr) <- getTreeModelFilterChildModel tmFilter + if childPtr == 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 childPtr == modelPtr + then return childIter + else convertIterFromParentToChildModel childIter child childModel + Nothing -> do + stamp <- get iter treeIterStamp + ud1 <- get iter treeIterUserData + ud2 <- get iter treeIterUserData2 + ud3 <- get iter treeIterUserData3 + error ("CellLayout: don't know how to convert iter "++show (stamp, ud1, ud2, ud3)++ + " from model "++show parentModelPtr++" to model "++ + show 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?") + diff --git a/src/Data/GI/Gtk/ModelView/CustomStore.hs b/src/Data/GI/Gtk/ModelView/CustomStore.hs new file mode 100644 --- /dev/null +++ b/src/Data/GI/Gtk/ModelView/CustomStore.hs @@ -0,0 +1,558 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE LambdaCase #-} +-- -*-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 (GObject(..), GType, CGType(..), gtypeToCGType, gtypeInt, gtypeBoolean, gtypeString, gtypeInvalid) +import Data.GI.Base.BasicConversions (gflagsToWord, withTextCString) +import Data.GI.Base.Overloading (ParentTypes) +import Data.GI.Base.ManagedPtr (newObject, withManagedPtr) +import Data.GI.Base.GValue (GValue(..)) +import GI.GObject (Object) +import GI.GdkPixbuf.Objects (Pixbuf(..)) +import GI.Gtk.Flags (TreeModelFlags(..)) +import GI.Gtk.Interfaces.TreeModel (TreeModel(..), TreeModelK) +import GI.Gtk.Structs (SelectionData(..), TreePath(..), TreeIter, treePathCopy, selectionDataCopy) +import Data.GI.Gtk.ModelView.Types +import GI.Gtk.Structs.TreeIter + (treeIterUserData3, treeIterUserData2, treeIterUserData, + treeIterStamp, 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 <- get iterIn treeIterStamp + ud1 <- get iterIn treeIterUserData + ud2 <- get iterIn treeIterUserData2 + ud3 <- get iterIn treeIterUserData3 + set iterOut [ + treeIterStamp := stamp, + treeIterUserData := ud1, + treeIterUserData2 := ud2, + treeIterUserData3 := 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 (ForeignPtr (CustomStore private row)) + +type instance ParentTypes (CustomStore private row) = CustomStoreParentTypes +type CustomStoreParentTypes = '[TreeModel, Object] + +instance GObject (CustomStore private row) where + gobjectIsInitiallyUnowned _ = False + gobjectType _ = gobjectType (undefined :: TreeModel) + +-- | 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, TypedTreeModelK 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 = + case toTypedTreeModel model of + TypedTreeModel model -> liftIO $ do + ptr <- withForeignPtr 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, TreeModelK (model row), TypedTreeModelK 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, TypedTreeModelK model) => model row -> TreeIter -> m row +customStoreGetRow model iter = liftIO $ + case toTypedTreeModel model of + TypedTreeModel model -> do + impl <- withForeignPtr 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 (CustomStore model) = + unsafePerformIO $ -- this is safe because the priv member is set at + -- construction time and never modified after that + withForeignPtr 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 (CustomStore model) = liftIO $ fromIntegral <$> + withForeignPtr 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 (CustomStore model) = liftIO $ + withForeignPtr 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 $ gobjectType (undefined :: 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 <$> newForeignPtr_ iterPtr -- Take care not to use this outside of this function + store <- customStoreIface <$> deRefStablePtr storePtr + path <- treePathCopy . TreePath =<< newForeignPtr_ 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 <$> newForeignPtr_ 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 <$> newForeignPtr_ 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 <$> newForeignPtr_ 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 <$> newForeignPtr_ 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 =<< newForeignPtr_ 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 =<< newForeignPtr_ pathPtr + selection <- selectionDataCopy . SelectionData =<< newForeignPtr_ 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 =<< newForeignPtr_ 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 =<< newForeignPtr_ pathPtr + selection <- selectionDataCopy . SelectionData =<< newForeignPtr_ 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 =<< newForeignPtr_ pathPtr + selection <- selectionDataCopy . SelectionData =<< newForeignPtr_ 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) diff --git a/src/Data/GI/Gtk/ModelView/ForestStore.hs b/src/Data/GI/Gtk/ModelView/ForestStore.hs new file mode 100644 --- /dev/null +++ b/src/Data/GI/Gtk/ModelView/ForestStore.hs @@ -0,0 +1,793 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ScopedTypeVariables #-} +-- -*-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 (GObject(..), GObject) +import Data.GI.Base.Overloading (ParentTypes) +import Data.GI.Base.ManagedPtr (withManagedPtr) + +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(..), + treeModelRowHasChildToggled) +import GI.Gtk.Functions (treeSetRowDragData, treeGetRowDragData) +import GI.Gtk.Structs.TreePath + (TreePath) +import GI.Gtk.Structs.TreeIter + (treeIterUserData3, treeIterUserData2, treeIterUserData, + treeIterStamp, TreeIter(..)) +import Data.GI.Base (get) +import Unsafe.Coerce (unsafeCoerce) +import Data.GI.Base.Constructible (Constructible(..)) +import Data.GI.Base.Attributes (AttrOp(..)) + +-------------------------------------------- +-- internal model data types +-- + +data ForestStoreIter = ForestStoreIter Int32 Word32 Word32 Word32 + +fromForestStoreIter :: MonadIO m => ForestStoreIter -> m TreeIter +fromForestStoreIter (ForestStoreIter s u1 u2 u3) = new TreeIter [ + treeIterStamp := s, + treeIterUserData := unsafeCoerce u1, + treeIterUserData2 := unsafeCoerce u2, + treeIterUserData3 := unsafeCoerce u3] + +toForestStoreIter :: MonadIO m => TreeIter -> m ForestStoreIter +toForestStoreIter iter = do + stamp <- get iter treeIterStamp + u1 <- get iter treeIterUserData + u2 <- get iter treeIterUserData2 + u3 <- get iter treeIterUserData3 + 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 (ForeignPtr (CustomStore (IORef (Store a)) a)) + +mkForestStore :: CustomStore (IORef (Store a)) a -> ForestStore a +mkForestStore (CustomStore ptr) = ForestStore ptr + +type instance ParentTypes (ForestStore a) = ForestStoreParentTypes +type ForestStoreParentTypes = '[TreeModel, Object] + +instance GObject (ForestStore a) where + gobjectIsInitiallyUnowned _ = False + gobjectType _ = gobjectType (undefined :: TreeModel) + +instance TypedTreeModelK 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 diff --git a/src/Data/GI/Gtk/ModelView/SeqStore.hs b/src/Data/GI/Gtk/ModelView/SeqStore.hs new file mode 100644 --- /dev/null +++ b/src/Data/GI/Gtk/ModelView/SeqStore.hs @@ -0,0 +1,385 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DataKinds #-} +-- -*-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 (GObject(..), GObject) +import Data.GI.Base.Overloading (ParentTypes) +import Data.GI.Base.ManagedPtr (withManagedPtr) +import GI.Gtk.Interfaces.TreeModel + (treeModelRowDeleted, treeModelRowInserted, + treeModelRowChanged, toTreeModel, TreeModel(..)) +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 + (treeIterUserData3, treeIterUserData2, treeIterStamp, + treeIterUserData, TreeIter(..)) +import Data.GI.Base (get) +import Data.Word (Word32) +import Unsafe.Coerce (unsafeCoerce) +import Data.GI.Base.Constructible (Constructible(..)) +import Data.GI.Base.Attributes (AttrOp(..)) +import Foreign.Ptr (nullPtr) + +seqStoreIterNew :: MonadIO m => Int32 -> Int32 -> m TreeIter +seqStoreIterNew s u1 = new TreeIter [ + treeIterStamp := s, + treeIterUserData := unsafeCoerce u1, + treeIterUserData2 := nullPtr, + treeIterUserData3 := nullPtr] + +newtype SeqStore a = SeqStore (ForeignPtr (CustomStore (IORef (Seq a)) a)) + +mkSeqStore :: CustomStore (IORef (Seq a)) a -> SeqStore a +mkSeqStore (CustomStore ptr) = SeqStore ptr + +type instance ParentTypes (SeqStore a) = SeqStoreParentTypes +type SeqStoreParentTypes = '[TreeModel, Object] + +instance GObject (SeqStore a) where + gobjectIsInitiallyUnowned _ = False + gobjectType _ = gobjectType (undefined :: TreeModel) + +instance TypedTreeModelK 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 <$> get i treeIterUserData + +-- | 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 + diff --git a/src/Data/GI/Gtk/ModelView/TreeModel.hs b/src/Data/GI/Gtk/ModelView/TreeModel.hs new file mode 100644 --- /dev/null +++ b/src/Data/GI/Gtk/ModelView/TreeModel.hs @@ -0,0 +1,190 @@ +{-# LANGUAGE LambdaCase #-} +-- -*-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. +-- +-- | +-- 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 :: TreeModelK 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, TreeModelK 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 diff --git a/src/Data/GI/Gtk/ModelView/Types.hs b/src/Data/GI/Gtk/ModelView/Types.hs new file mode 100644 --- /dev/null +++ b/src/Data/GI/Gtk/ModelView/Types.hs @@ -0,0 +1,221 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE LambdaCase #-} +-- -*-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(..), + TypedTreeModelK, + toTypedTreeModel, + unsafeTreeModelToGeneric, + + TypedTreeModelSort(..), + unsafeTreeModelSortToGeneric, + TypedTreeModelFilter(..), + unsafeTreeModelFilterToGeneric, + + -- TreePath + treePathNewFromIndices', + treePathGetIndices', + withTreePath, + maybeWithTreePath, + 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.ForeignPtr (ForeignPtr, newForeignPtr_) +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 (ForeignPtrNewtype, UnexpectedNullPointerReturn, GObject(..)) +import Data.GI.Base.ManagedPtr (withManagedPtr) +import Data.GI.Base.GValue (GValue) +import Data.GI.Base.Overloading (ParentTypes) +import GI.GObject.Objects.Object (Object(..)) +import GI.Gtk.Interfaces.TreeModel (TreeModel) +import GI.Gtk.Objects.TreeModelSort (TreeModelSort) +import GI.Gtk.Objects.TreeSelection (TreeSelectionK, treeSelectionCountSelectedRows, treeSelectionGetSelectedRows) +import GI.Gtk.Objects.TreeModelFilter (TreeModelFilter) +import GI.Gtk.Interfaces.TreeSortable (TreeSortable) +import GI.GLib.Functions (quarkFromString) +import GI.GdkPixbuf.Objects.Pixbuf (Pixbuf(..)) +import GI.Gtk.Structs.TreeIter + (treeIterUserData3, treeIterUserData2, treeIterUserData, + treeIterStamp, TreeIter(..), treeIterCopy) +import GI.Gtk.Structs.TreePath (TreePath(..), treePathGetIndices, treePathNewFromIndices, treePathNew, treePathGetDepth) +import Data.GI.Base.Constructible (Constructible(..)) +import Data.GI.Base.Attributes (AttrOp(..)) +import Unsafe.Coerce (unsafeCoerce) +import Data.GI.Base (set, get) + +nullForeignPtr :: ForeignPtr a +nullForeignPtr = unsafePerformIO $ newForeignPtr_ nullPtr + +equalManagedPtr :: ForeignPtrNewtype a => a -> a -> Bool +equalManagedPtr a b = + (coerce a :: ForeignPtr ()) == (coerce b :: ForeignPtr ()) + +newtype TypedTreeModel row = TypedTreeModel (ForeignPtr (TypedTreeModel row)) + +class TypedTreeModelK 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 :: TypedTreeModelK model => model row -> TypedTreeModel row +toTypedTreeModel = unsafeCoerce# + +unsafeTreeModelToGeneric :: TreeModel -> model row +unsafeTreeModelToGeneric = unsafeCoerce# + +instance TypedTreeModelK TypedTreeModel + +newtype TypedTreeModelSort row = TypedTreeModelSort (ForeignPtr (TypedTreeModelSort row)) + +type instance ParentTypes (TypedTreeModelSort row) = TypedTreeModelSortParentTypes +type TypedTreeModelSortParentTypes = '[TreeModelSort, TreeSortable, TreeModel, Object] + +instance GObject (TypedTreeModelSort row) where + gobjectIsInitiallyUnowned _ = False + gobjectType _ = gobjectType (undefined :: TreeModelSort) + +unsafeTreeModelSortToGeneric :: TreeModelSort -> TypedTreeModelSort row +unsafeTreeModelSortToGeneric = unsafeCoerce# + +instance TypedTreeModelK TypedTreeModelSort + +newtype TypedTreeModelFilter row = TypedTreeModelFilter (ForeignPtr (TypedTreeModelFilter row)) + +unsafeTreeModelFilterToGeneric :: TreeModelFilter -> TypedTreeModelFilter row +unsafeTreeModelFilterToGeneric = unsafeCoerce# + +instance TypedTreeModelK 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 = treePathNewFromIndices x + +treePathGetIndices' :: MonadIO m => TreePath -> m [Int32] +treePathGetIndices' path = treePathGetDepth path >>= \case + 0 -> return [] + _ -> treePathGetIndices path + +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 nullForeignPtr)) (`withTreePath` act) mbTp + +treeSelectionGetSelectedRows' :: (MonadIO m, TreeSelectionK 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") +