522 lines
18 KiB
EmacsLisp
522 lines
18 KiB
EmacsLisp
;;; gobgen.el --- Generate GObject descendants using a detailed form -*- lexical-binding: nil; -*-
|
|
|
|
;; Copyright (C) 2015 Gergely Polonkai
|
|
|
|
;; Author: Gergely Polonkai <gergely@polonkai.eu>
|
|
;; 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 <http://www.gnu.org/licenses/>.
|
|
|
|
;;; 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 <glib-object.h>"
|
|
(if (string-equal "gtk" parent-prefix-snake)
|
|
"#include <gtk/gtk.h>"
|
|
(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
|