1 ;;; ztree-util.el --- Auxulary utilities for the ztree package
3 ;; Copyright (C) 2013 Alexey Veretennikov
5 ;; Author: Alexey Veretennikov <alexey dot veretennikov at gmail dot com>
9 ;; URL: https://github.com/fourier/ztree
10 ;; Compatibility: GNU Emacs GNU Emacs 24.x
12 ;; This file is NOT part of GNU Emacs.
14 ;; This program is free software; you can redistribute it and/or
15 ;; modify it under the terms of the GNU General Public License
16 ;; as published by the Free Software Foundation; either version 2
17 ;; of the License, or (at your option) any later version.
19 ;; This program is distributed in the hope that it will be useful,
20 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
21 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
22 ;; GNU General Public License for more details.
24 ;; You should have received a copy of the GNU General Public License
25 ;; along with this program. If not, see <http://www.gnu.org/licenses/>.
30 (defun ztree-find (where which)
31 "find element of the list `where` matching predicate `which`"
34 (when (funcall which elt)
38 (defun ztree-filter (condp lst)
39 "Filter out elements of the list `lst` not satisfying predicate `condp`.
40 Taken from http://www.emacswiki.org/emacs/ElispCookbook#toc39"
42 (mapcar (lambda (x) (and (funcall condp x) x)) lst)))
45 (defun printable-string (string)
46 "Strip newline character from file names, like 'Icon\n'"
47 (replace-regexp-in-string "\n" "" string))
49 (defun file-short-name (file)
50 "Base file/directory name. Taken from
51 http://lists.gnu.org/archive/html/emacs-devel/2011-01/msg01238.html"
52 (printable-string (file-name-nondirectory (directory-file-name file))))
55 (defun newline-and-begin ()
59 (defun car-atom (value)
60 "Returns value if value is an atom, otherwise (car value) or nil.
61 Used since car-safe returns nil for atoms"
62 (if (atom value) value (car value)))
65 (defun insert-with-face (text face)
66 "Insert text with the face provided"
67 (let ((start (point)))
69 (put-text-property start (point) 'face face)))
72 (defmacro defrecord (record-name record-fields)
73 "Create a record (structure) and getters/setters.
75 Record is the following set of functions:
76 - Record constructor with name \"record-name\"-create and list of
77 arguments which will be assigned to record-fields
78 - Record getters with names \"record-name\"-\"field\" accepting one
79 argument - the record; \"field\" is from \"record-fields\" symbols
80 - Record setters with names \"record-name\"-set-\"field\" accepting two
81 arguments - the record and the field value
84 \(defrecord person (name age))
86 will be expanded to the following functions:
88 \(defun person-create (name age) (...)
89 \(defun person-name (record) (...)
90 \(defun person-age (record) (...)
91 \(defun person-set-name (record value) (...)
92 \(defun person-set-age (record value) (...)"
93 (let ((ctor-name (intern (concat (symbol-name record-name) "-create")))
94 (rec-var (make-symbol "record")))
96 ;; constructor with the name "record-name-create"
97 ;; with arguments list "record-fields" expanded
98 (defun ,ctor-name (,@record-fields)
100 ,@(mapcar #'(lambda (x)
101 (list 'setq rec-var (list 'plist-put rec-var (list 'quote x) x)))
103 ;; getters with names "record-name-field" where the "field"
104 ;; is from record-fields
105 ,@(mapcar #'(lambda (x)
106 (let ((getter-name (intern (concat (symbol-name record-name)
110 (defun ,getter-name (,rec-var)
111 (plist-get ,rec-var ',x)
114 ;; setters wit names "record-name-set-field where the "field"
115 ;; is from record-fields
116 ;; arguments for setters: (record value)
117 ,@(mapcar #'(lambda (x)
118 (let ((setter-name (intern (concat (symbol-name record-name)
122 (defun ,setter-name (,rec-var value)
123 (setq ,rec-var (plist-put ,rec-var ',x value))
128 (provide 'ztree-util)
130 ;;; ztree-util.el ends here