;;; gobgen.el --- Generate GObject descendants using a detailed form -*- lexical-binding: nil; -*- ;; Copyright (C) 2015 Gergely Polonkai ;; Author: Gergely Polonkai ;; Keywords: gobject, glib, gtk, helper, utilities ;; Package-Version: 20161020.823 ;; Version: 0.0.1 ;; Package-Requires: ((emacs "24.4")) ;; This program is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation, either version 3 of the License, or ;; (at your option) any later version. ;; This program 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 General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with this program. If not, see . ;;; Commentary: ;; Generator code is highly based on Gustavo Sverzut Barbieri's ;; gobject-class.el ;;; Code: (require 'widget) (require 'wid-edit) (require 'subr-x) (defvar-local gobgen-widget-name nil "Widget for the class name.") (defvar-local gobgen-widget-prefix nil "Widget for the class prefix. It is auto-filled, but changeable.") (defvar-local gobgen-widget-parent-name nil "Widget for the name of the parent class.") (defvar-local gobgen-widget-parent-prefix nil "Widget for the prefix of the parent class. It is auto-filled, but changeable.") (defvar-local gobgen-widget-recent nil "Checkbox field for the recent GLib option.") (defvar-local gobgen-widget-private nil "Checkbox field for the private structure option.") (defun gobject-get-prefix (class-name) "Guess the GObject prefix from CLASS-NAME." (car (split-string class-name "_"))) (defun gobgen-gen-header (class-full-name-upper class-prefix-upper class-name-upper class-full-name-camel func-prefix parent-prefix-snake parent-prefix-camel parent-name-camel parent-header recent-glib need-private) "Generate the contents of a GObject header file. CLASS-FULL-NAME-UPPER is the full GObject name of the new class in UPPER_SNAKE_CASE notation. CLASS-PREFIX-UPPER is the GObject prefix of the new class in UPPER_SNAKE_CASE notation. CLASS-NAME-UPPER is the name of the new class without the prefix in UPPER_SNAKE_CASE notation. CLASS-FULL-NAME-CAMEL is the full name of the new object in CamelCase notation. FUNC-PREFIX is the function prefix for object methods. Usually it is the same as the full object name in lower_snake_case notation. PARENT-PREFIX-SNAKE is the prefix of the parent object in snake_case notation. PARENT-PREFIX-CAMEL is the prefix of the parent object in CamelCase notation. PARENT-NAME-CAMEL is the name of the parent class without the prefix, in CamelCase notation. PARENT-HEADER is the name of the header file to be included in order to use the parent class. If RECENT-GLIB is 't', some features available from GLib 2.38 will be used. If NEED-PRIVATE is 't', a private struct will be added to the new class." (concat "#ifndef __" class-full-name-upper "_H__\n" "#define __" class-full-name-upper "_H__\n" "\n" (if (string-equal "g" parent-prefix-snake) "#include " (if (string-equal "gtk" parent-prefix-snake) "#include " (concat "// You might want to revise this\n" "#include <" parent-header ">"))) "\n" "\n" "G_BEGIN_DECLS\n" "\n" "#define " class-prefix-upper "_TYPE_" class-name-upper " (" func-prefix "_get_type())\n" "#define " class-full-name-upper "(o) (G_TYPE_CHECK_INSTANCE_CAST((o), " class-prefix-upper "_TYPE_" class-name-upper ", " class-full-name-camel "))\n" "#define " class-full-name-upper "_CLASS(k) (G_TYPE_CHECK_CLASS_CAST((k), " class-prefix-upper "_TYPE_" class-name-upper ", " class-full-name-camel "Class))\n" "#define " class-prefix-upper "_IS_" class-name-upper "(o) (G_TYPE_CHECK_INSTANCE_TYPE((o), " class-prefix-upper "_TYPE_" class-name-upper "))\n" "#define " class-prefix-upper "_IS_" class-name-upper "_CLASS(k) (G_TYPE_CHECK_CLASS_TYPE((k), " class-prefix-upper "_TYPE_" class-name-upper "))\n" "#define " class-full-name-upper"_GET_CLASS(o) (G_TYPE_INSTANCE_GET_CLASS((o), " class-prefix-upper "_TYPE_" class-name-upper ", " class-full-name-camel "Class))\n" "\n" "typedef struct _" class-full-name-camel " " class-full-name-camel ";\n" "typedef struct _" class-full-name-camel "Class " class-full-name-camel "Class;\n" (if (and (not recent-glib) need-private) (concat "typedef struct _" class-full-name-camel "Private " class-full-name-camel "Private;\n")) "\n" "struct _" class-full-name-camel " {\n" " /* Parent instance structure */\n" " " parent-prefix-camel parent-name-camel " parent_instance;\n" "\n" " /* Instance members */\n" (if (and (not recent-glib) need-private) (concat "\n" " /*< private >*/\n" " " class-full-name-camel "Private *priv;\n")) "};\n" "\n" "struct _" class-full-name-camel "Class {\n" " " parent-prefix-camel parent-name-camel "Class parent_class;\n" "};\n" "\n" "GType " func-prefix "_get_type(void) G_GNUC_CONST;\n" "\n" "G_END_DECLS\n" "\n" "#endif /* __" class-full-name-upper "_H__ */\n")) (defun gobgen-gen-code (class-full-name-upper class-prefix-upper class-name-upper class-name-snake class-full-name-camel func-prefix file-name-header parent-prefix-upper parent-name-upper recent-glib need-private) "Generate the contents of a GObject source file. CLASS-FULL-NAME-UPPER is the full GObject name of the new class in UPPER_SNAKE_CASE notation. CLASS-PREFIX-UPPER is the GObject prefix of the new class in UPPER_SNAKE_CASE notation. CLASS-NAME-UPPER is the name of the new class without the prefix in UPPER_SNAKE_CASE notation. CLASS-NAME-SNAKE is the name of the new class without the prefix in snake_case notation. CLASS-FULL-NAME-CAMEL is the full name of the new object in CamelCase notation. FUNC-PREFIX is the function prefix for object methods. Usually it is the same as the full object name in lower_snake_case notation. FILE-NAME-HEADER is the name of the header file generated for the new class. PARENT-PREFIX-UPPER is the prefix of the parent object in UPPER_SNAKE_CASE notation. PARENT-NAME-UPPER is the name of the parent class without the prefix in UPPER_SNAKE_CASE notation. If RECENT-GLIB is 't', some features available from GLib 2.38 will be used. If NEED-PRIVATE is 't', a private struct will be added to the new class." (concat "#include \"" file-name-header "\"\n" "\n" (if need-private (concat (if (not recent-glib) (concat "#define " class-full-name-upper "_GET_PRIVATE(o) (G_TYPE_INSTANCE_GET_PRIVATE( \\\n" " (o), \\\n" " " class-prefix-upper "_TYPE_" class-name-upper ", \\\n" " " class-full-name-camel "Private \\\n" " ))\n" "\n")) (if recent-glib "typedef ") "struct _" class-full-name-camel "Private {\n" " /* TODO: You must add something here, or GLib will produce warnings! */\n" "}" (if recent-glib (concat " " class-full-name-camel "Private")) ";\n" "\n")) "G_DEFINE_TYPE" (if (and recent-glib need-private) "_WITH_PRIVATE") "(" class-full-name-camel ", " func-prefix ", " parent-prefix-upper "_TYPE_" parent-name-upper ");\n" "\n" "static void\n" func-prefix "_finalize(GObject *gobject)\n" "{\n" " g_signal_handlers_destroy(gobject);\n" " G_OBJECT_CLASS(" func-prefix "_parent_class)->finalize(gobject);\n" "}\n" "\n" "static void\n" func-prefix "_class_init(" class-full-name-camel "Class *klass)\n" "{\n" " GObjectClass *gobject_class = G_OBJECT_CLASS(klass);\n" "\n" (if (and (not recent-glib) need-private) (concat " g_type_class_add_private(klass, sizeof(" class-full-name-camel "Private));\n" "\n")) " gobject_class->finalize = " func-prefix "_finalize;\n" "}\n" "\n" "static void\n" func-prefix "_init(" class-full-name-camel " *" class-name-snake ")\n" "{\n" (if (and (not recent-glib) need-private) (concat " " class-name-snake "->priv = " class-full-name-upper "_GET_PRIVATE(" class-name-snake ");\n")) "}\n")) (defun gobgen-generator (class-prefix class-name parent-prefix parent-name recent-glib need-private) "Generate the boilerplate of a new GObject derived class. CLASS-PREFIX is the prefix of the new class. CLASS-NAME is the name of the new class, without the prefix. PARENT-PREFIX is the prefix of the parent class. PARENT-NAME is the name of the parent class, without the prefix. If RECENT-GLIB is 't', some features available from GLib 2.38 will be used. If NEED-PRIVATE is 't', a private struct will be added to the new class." (let* ((parent-prefix (downcase parent-prefix)) (parent-name (downcase parent-name)) (class-prefix (downcase class-prefix)) (class-name (downcase class-name)) (parent-prefix-length (length parent-prefix)) (class-prefix-length (length class-prefix))) (if (not (string-prefix-p (concat parent-prefix "_") parent-name)) (message (concat "Parent (" parent-name ") and parent prefix (" parent-prefix ") don't match")) (if (not (string-prefix-p (concat class-prefix "_") class-name)) (message (concat "Class (" class-name ") and class prefix (" class-prefix ") don't match")) (let* ((parent-name (substring parent-name (+ parent-prefix-length 1))) (class-name (substring class-name (+ class-prefix-length 1))) (parent-prefix-pcs (split-string parent-prefix "_")) (parent-name-pcs (split-string parent-name "_")) (class-prefix-pcs (split-string class-prefix "_")) (class-name-pcs (split-string class-name "_")) (parent-prefix-snake (string-join parent-prefix-pcs "_")) (parent-prefix-camel (mapconcat 'capitalize parent-prefix-pcs "")) (parent-prefix-upper (upcase parent-prefix-snake)) (parent_name (string-join parent-name-pcs "_")) (parent-name-camel (mapconcat 'capitalize parent-name-pcs "")) (parent-name-upper (upcase parent_name)) (class_prefix (string-join class-prefix-pcs "_")) (ClassPrefix (mapconcat 'capitalize class-prefix-pcs "")) (class-prefix-upper (upcase class_prefix)) (class-name-snake (string-join class-name-pcs "_")) (ClassName (mapconcat 'capitalize class-name-pcs "")) (class-name-upper (upcase class-name-snake)) (func-prefix (concat class_prefix "_" class-name-snake)) (class-full-name-camel (concat ClassPrefix ClassName)) (class-full-name-upper (concat class-prefix-upper "_" class-name-upper)) (parent-header (concat (string-join (append parent-prefix-pcs parent-name-pcs) "-") ".h")) (file-name-base (string-join (append class-prefix-pcs class-name-pcs) "-")) (file-name-code (concat file-name-base ".c")) (file-name-header (concat file-name-base ".h"))) (delete-other-windows) (split-window-vertically) (other-window 1) (find-file file-name-header) (insert (gobgen-gen-header class-full-name-upper class-prefix-upper class-name-upper class-full-name-camel func-prefix parent-prefix-snake parent-prefix-camel parent-name-camel parent-header recent-glib need-private)) (split-window-vertically) (other-window 1) (find-file file-name-code) (insert (gobgen-gen-code class-full-name-upper class-prefix-upper class-name-upper class-name-snake class-full-name-camel func-prefix file-name-header parent-prefix-upper parent-name-upper recent-glib need-private))))))) ;;;###autoload (defun gobgen () "Create widgets window for GObject creation." (interactive) (switch-to-buffer "*GObject Creator*") (kill-all-local-variables) (let ((inhibit-read-only t)) (erase-buffer)) (remove-overlays) (widget-insert "GObject Creator\n\n") (widget-insert "Generate a GObject class skeleton.\n\n") (setq gobgen-widget-name (widget-create 'editable-field :size 25 :format "Name: %v" :notify (lambda (widget _child &optional event) (save-excursion (widget-value-set gobgen-widget-prefix (gobject-get-prefix (widget-value widget))))) :doc "The name of the new class, with its prefix included" "gtk_example_object")) (widget-insert " ") (setq gobgen-widget-prefix (widget-create 'editable-field :size 10 :format "Prefix: %v\n" :doc "Prefix of the new class. It updates automatically based on the name, so unless you need a namespace that consists of multiple parts (like my_ns), you should not touch this." "gtk")) (setq gobgen-widget-parent-name (widget-create 'editable-field :size 25 :format "Parent: %v" :notify (lambda (widget _child &optional event) (save-excursion (widget-value-set gobgen-widget-parent-prefix (gobject-get-prefix (widget-value widget))))) :doc "Name of the parent class. Use g_object if you don't want to derive from something specific." "g_object")) (widget-insert " ") (setq gobgen-widget-parent-prefix (widget-create 'editable-field :size 10 :format "Prefix: %v\n" :doc "Prefix of the parent class. Its automatically set value should suffice most of the time" "g")) (widget-insert "\n") (setq gobgen-widget-recent (widget-create 'checkbox :doc "Use recent GLib's features, like defining a class with a private struct. Usually you would want this on." t)) (widget-insert " GLib >= 2.38\n") (setq gobgen-widget-private (widget-create 'checkbox :doc "Add a private struct for the object." nil)) (widget-insert " Has private members\n") (widget-insert "\n\n") (widget-create 'push-button :notify (lambda (widget _child &optional event) (let ((class-name (widget-value gobgen-widget-name)) (class-prefix (widget-value gobgen-widget-prefix)) (parent-name (widget-value gobgen-widget-parent-name)) (parent-prefix (widget-value gobgen-widget-parent-prefix)) (recent-glib (widget-value gobgen-widget-recent)) (need-private (widget-value gobgen-widget-private))) (gobgen-generator class-prefix class-name parent-prefix parent-name recent-glib need-private))) "Generate") (widget-insert " ") (widget-create 'push-button :notify (lambda (widget _child &optional event) (widget-value-set gobgen-widget-name "gtk_example_object") (widget-value-set gobgen-widget-prefix "gtx") (widget-value-set gobgen-widget-parent-name "g_object") (widget-value-set gobgen-widget-parent-prefix "g") (widget-value-set gobgen-widget-recent t) (widget-value-set gobgen-widget-private nil)) "Reset form") (widget-insert " ") (widget-create 'push-button :notify (lambda (widget _child &optional event) (kill-buffer "*GObject Creator*")) "Close") (goto-char (point-min)) (use-local-map widget-keymap) (widget-setup)) (provide 'gobgen) ;;; gobgen.el ends here