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

   1 ;;; ztree-util.el --- Auxulary utilities for the ztree package -*- lexical-binding: t; -*-
   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 ztree-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 ztree-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   (ztree-printable-string (file-name-nondirectory (directory-file-name file))))
  55
  56 (defun ztree-car-atom (value)
  57   "Return VALUE if value is an atom, otherwise (car value) or nil.
  58 Used since `car-safe' returns nil for atoms"
  59   (if (atom value) value (car value)))
  60
  61
  62 (defun ztree-insert-with-face (text face)
  63   "Insert TEXT with the FACE provided."
  64   (let ((start (point)))
  65     (insert text)
  66     (put-text-property start (point) 'face face)))
  67
  68
  69 (defmacro ztree-defrecord (record-name record-fields)
  70   "Create a record (structure) and getters/setters.
  71
  72 Record is the following set of functions:
  73  - Record constructor with name \"RECORD-NAME\"-create and list of
  74 arguments which will be assigned to RECORD-FIELDS
  75  - Record getters with names \"record-name\"-\"field\" accepting one
  76 argument - the record; \"field\" is from \"record-fields\" symbols
  77  - Record setters with names \"record-name\"-set-\"field\" accepting two
  78 arguments - the record and the field value
  79
  80 Example:
  81 \(ztree-defrecord person (name age))
  82
  83 will be expanded to the following functions:
  84
  85 \(defun person-create (name age) (...)
  86 \(defun person-name (record) (...)
  87 \(defun person-age (record) (...)
  88 \(defun person-set-name (record value) (...)
  89 \(defun person-set-age (record value) (...)
  90
  91 To test expansion one can use GNU Emacs's pp library:
  92 \(require 'pp)
  93 \(pp-macroexpand-expression
  94  '(ztree-defrecord person (name age)))"
  95   (let ((ctor-name (intern (concat (symbol-name record-name) "-create")))
  96         (rec-var (make-symbol "record")))
  97     `(progn
  98        ;; constructor with the name "record-name-create"
  99        ;; with arguments list "record-fields" expanded
 100        (defun ,ctor-name (,@record-fields)
 101          (let ((,rec-var))
 102            ,@(mapcar #'(lambda (x)
 103                          (list 'setq rec-var (list 'plist-put rec-var (list 'quote x) x)))
 104                      record-fields)))
 105        ;; getters with names "record-name-field" where the "field"
 106        ;; is from record-fields
 107        ,@(mapcar #'(lambda (x)
 108                      (let ((getter-name (intern (concat (symbol-name record-name)
 109                                                         "-"
 110                                                         (symbol-name x)))))
 111                        `(progn
 112                           (defun ,getter-name (,rec-var)
 113                             (plist-get ,rec-var ',x)
 114                             ))))
 115                  record-fields)
 116        ;; setters wit names "record-name-set-field where the "field"
 117        ;; is from record-fields
 118        ;; arguments for setters: (record value)
 119        ,@(mapcar #'(lambda (x)
 120                      (let ((setter-name (intern (concat (symbol-name record-name)
 121                                                         "-set-"
 122                                                         (symbol-name x)))))
 123                        `(progn
 124                           (defun ,setter-name (,rec-var value)
 125                             (setq ,rec-var (plist-put ,rec-var ',x value))
 126                             ))))
 127                  record-fields))))
 128
 129
 130 (provide 'ztree-util)
 131
 132 ;;; ztree-util.el ends here