gi-gtk-hs (empty) → 0.2.0.0
raw patch · 14 files changed
+4033/−0 lines, 14 filesdep +basedep +base-compatdep +containerssetup-changed
Dependencies added: base, base-compat, containers, gi-gdk, gi-gdkpixbuf, gi-glib, gi-gobject, gi-gtk, haskell-gi-base, mtl, text, transformers
Files
- LICENSE +502/−0
- Setup.hs +2/−0
- cbits/Gtk2HsStore.c +801/−0
- cbits/quartzfix.c +18/−0
- gi-gtk-hs.cabal +49/−0
- src/Data/GI/Gtk.hs +20/−0
- src/Data/GI/Gtk/BuildFn.hs +60/−0
- src/Data/GI/Gtk/ComboBox.hs +246/−0
- src/Data/GI/Gtk/ModelView/CellLayout.hs +188/−0
- src/Data/GI/Gtk/ModelView/CustomStore.hs +558/−0
- src/Data/GI/Gtk/ModelView/ForestStore.hs +793/−0
- src/Data/GI/Gtk/ModelView/SeqStore.hs +385/−0
- src/Data/GI/Gtk/ModelView/TreeModel.hs +190/−0
- src/Data/GI/Gtk/ModelView/Types.hs +221/−0
+ LICENSE view
@@ -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.++ <one line to give the library's name and a brief idea of what it does.>+ Copyright (C) <year> <name of author>++ 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.++ <signature of Ty Coon>, 1 April 1990+ Ty Coon, President of Vice++That's all there is to it!
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ cbits/Gtk2HsStore.c view
@@ -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);+}
+ cbits/quartzfix.c view
@@ -0,0 +1,18 @@+#include <stdio.h>++void+gtk_drag_set_icon_gicon (void *context,+ void *icon,+ int hot_x,+ int hot_y)+{+ printf("gtk_drag_set_icon_gicon not implemented");+}++void+gtk_drag_source_set_icon_gicon (void *widget,+ void *icon)+{+ printf("gtk_drag_source_set_icon_gicon not implemented");+}+
+ gi-gtk-hs.cabal view
@@ -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+
+ src/Data/GI/Gtk.hs view
@@ -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
+ src/Data/GI/Gtk/BuildFn.hs view
@@ -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
+ src/Data/GI/Gtk/ComboBox.hs view
@@ -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)+
+ src/Data/GI/Gtk/ModelView/CellLayout.hs view
@@ -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?")+
+ src/Data/GI/Gtk/ModelView/CustomStore.hs view
@@ -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)
+ src/Data/GI/Gtk/ModelView/ForestStore.hs view
@@ -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<curIdx then+ moveToChild pos (d:ds) (dropWhile (isNonZero pos d) cache)+ else let+ -- advance the current iterator to coincide with the goal iterator+ -- at this level+ moveWithinLevel pos d ((ti,forest):parents) = let+ diff = fromIntegral (goalIdx-curIdx)+ (dropped, remain) = splitAt diff forest+ advance = length dropped+ ti' = setBitSlice ti pos d (curIdx+fromIntegral advance)+ in+ if advance==diff then moveToChild (pos+d) ds ((ti',remain):parents)+ else (ti',remain):parents -- node not found+ in moveWithinLevel pos d $ case ds of+ [] -> 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<childIdx then ((ti',remain):cache) else+ moveToChild (pos+d) ds ((ti',remain):cache)++-- | Advance to the given iterator and return weather this was successful.+--+checkSuccess :: Depth -> 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
+ src/Data/GI/Gtk/ModelView/SeqStore.hs view
@@ -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+
+ src/Data/GI/Gtk/ModelView/TreeModel.hs view
@@ -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
+ src/Data/GI/Gtk/ModelView/Types.hs view
@@ -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")+