code.delx.au - gnu-emacs-elpa/blob - packages/ztree/ztree-util.el

   1 ;;; ztree-util.el --- Auxulary utilities for the ztree package
   2
   3 ;; Copyright (C) 2013-2015  Free Software Foundation, Inc.
   4 ;;
   5 ;; Author: Alexey Veretennikov <alexey dot veretennikov at gmail dot com>
   6 ;;
   7 ;; Created: 2013-11-1l
   8 ;;
   9 ;; Keywords: files tools
  10 ;; URL: https://github.com/fourier/ztree
  11 ;; Compatibility: GNU Emacs 24.x
  12 ;;
  13 ;; This file is part of GNU Emacs.
  14 ;;
  15 ;; GNU Emacs is free software: you can redistribute it and/or modify
  16 ;; it under the terms of the GNU General Public License as published by
  17 ;; the Free Software Foundation, either version 3 of the License, or
  18 ;; (at your option) any later version.
  19 ;;
  20 ;; GNU Emacs is distributed in the hope that it will be useful,
  21 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  22 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  23 ;; GNU General Public License for more details.
  24 ;;
  25 ;; You should have received a copy of the GNU General Public License
  26 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  27 ;;
  28 ;;; Commentary:
  29
  30 ;;; Code:
  31 (defun ztree-find (where which)
  32   "Find element of the list WHERE matching predicate WHICH."
  33   (catch 'found
  34     (dolist (elt where)
  35       (when (funcall which elt)
  36         (throw 'found elt)))
  37     nil))
  38
  39 (defun ztree-filter (condp lst)
  40   "Filter out elements not satisfying predicate CONDP in the list LST.
  41 Taken from http://www.emacswiki.org/emacs/ElispCookbook#toc39"
  42   (delq nil
  43         (mapcar (lambda (x) (and (funcall condp x) x)) lst)))
  44
  45
  46 (defun printable-string (string)
  47   "Strip newline character from file names, like 'Icon\n.
  48 Argument STRING string to process.'."
  49   (replace-regexp-in-string "\n" "" string))
  50
  51 (defun file-short-name (file)
  52   "By given FILE name return base file/directory name.
  53 Taken from http://lists.gnu.org/archive/html/emacs-devel/2011-01/msg01238.html"
  54   (printable-string (file-name-nondirectory (directory-file-name file))))
  55
  56
  57 (defun newline-and-begin ()
  58   "Move a point to the beginning of the next line."
  59   (insert "\n")
  60   (beginning-of-line))
  61
  62 (defun car-atom (value)
  63   "Return VALUE if value is an atom, otherwise (car value) or nil.
  64 Used since `car-safe' returns nil for atoms"
  65   (if (atom value) value (car value)))
  66
  67
  68 (defun insert-with-face (text face)
  69   "Insert TEXT with the FACE provided."
  70   (let ((start (point)))
  71     (insert text)
  72     (put-text-property start (point) 'face face)))
  73
  74
  75 (defmacro defrecord (record-name record-fields)
  76   "Create a record (structure) and getters/setters.
  77
  78 Record is the following set of functions:
  79  - Record constructor with name \"RECORD-NAME\"-create and list of
  80 arguments which will be assigned to RECORD-FIELDS
  81  - Record getters with names \"record-name\"-\"field\" accepting one
  82 argument - the record; \"field\" is from \"record-fields\" symbols
  83  - Record setters with names \"record-name\"-set-\"field\" accepting two
  84 arguments - the record and the field value
  85
  86 Example:
  87 \(defrecord person (name age))
  88
  89 will be expanded to the following functions:
  90
  91 \(defun person-create (name age) (...)
  92 \(defun person-name (record) (...)
  93 \(defun person-age (record) (...)
  94 \(defun person-set-name (record value) (...)
  95 \(defun person-set-age (record value) (...)"
  96   (let ((ctor-name (intern (concat (symbol-name record-name) "-create")))
  97         (rec-var (make-symbol "record")))
  98     `(progn
  99        ;; constructor with the name "record-name-create"
 100        ;; with arguments list "record-fields" expanded
 101        (defun ,ctor-name (,@record-fields)
 102          (let ((,rec-var))
 103            ,@(mapcar #'(lambda (x)
 104                       (list 'setq rec-var (list 'plist-put rec-var (list 'quote x) x)))
 105                     record-fields)))
 106        ;; getters with names "record-name-field" where the "field"
 107        ;; is from record-fields
 108        ,@(mapcar #'(lambda (x)
 109                     (let ((getter-name (intern (concat (symbol-name record-name)
 110                                                        "-"
 111                                                        (symbol-name x)))))
 112                       `(progn
 113                          (defun ,getter-name (,rec-var)
 114                            (plist-get ,rec-var ',x)
 115                            ))))
 116                 record-fields)
 117        ;; setters wit names "record-name-set-field where the "field"
 118        ;; is from record-fields
 119        ;; arguments for setters: (record value)
 120        ,@(mapcar #'(lambda (x)
 121                      (let ((setter-name (intern (concat (symbol-name record-name)
 122                                                         "-set-"
 123                                                         (symbol-name x)))))
 124                        `(progn
 125                           (defun ,setter-name (,rec-var value)
 126                             (setq ,rec-var (plist-put ,rec-var ',x value))
 127                             ))))
 128                  record-fields))))
 129
 130
 131 (provide 'ztree-util)
 132
 133 ;;; ztree-util.el ends here