code.delx.au - gnu-emacs/blob - lisp/fadr.el

   1 ;;; fadr.el --- convenient access to recursive list structures
   2
   3 ;; Copyright (C) 2009 Free Software Foundation, Inc.
   4
   5 ;; Author: Dmitry Dzhus <dima@sphinx.net.ru>
   6 ;; Keywords: lisp, internal
   7
   8 ;; This program is free software; you can redistribute it and/or modify
   9 ;; it under the terms of the GNU General Public License as published by
  10 ;; the Free Software Foundation, either version 3 of the License, or
  11 ;; (at your option) any later version.
  12
  13 ;; This program is distributed in the hope that it will be useful,
  14 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  15 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16 ;; GNU General Public License for more details.
  17
  18 ;; You should have received a copy of the GNU General Public License
  19 ;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
  20
  21 ;;; Commentary:
  22
  23 ;; This code allows accessing data stored in recursive association and
  24 ;; plain lists using a compact notation.
  25 ;;
  26 ;; Consider the following list:
  27 ;;
  28 ;;     (setq basket '((apples . (((color . green) (taste . delicious)) ((color . red) (taste . disgusting))))))
  29 ;;
  30 ;; Its contents may be accessed using `fadr-member':
  31 ;;
  32 ;;     (fadr-member basket ".apples[1].color")
  33 ;;     red
  34 ;;
  35 ;; Associated values are selected using a dot followed by a key, while
  36 ;; lists accept an index (0-based) in square brackets.
  37 ;;
  38 ;; `fadr-q' is a one-argument shortcut fro `fadr-member', where
  39 ;; (fadr-q "res.path") results to (fadr-member res ".path"):
  40 ;;
  41 ;;     (fadr-q "basket.apples[0].taste")
  42 ;;     delicious
  43 ;;
  44 ;; `fadr-expand' substitutes ~PATH with results of `fadr-member' calls
  45 ;; with respective arguments:
  46 ;;
  47 ;;     (fadr-expand "~.color apple is ~.taste" (fadr-member basket ".apples[0]"))
  48 ;;     "green apple is delicious"
  49 ;;
  50 ;; `fadr-format' is like `fadr-expand', but it performs %-substitutions first:
  51 ;;
  52 ;;     (fadr-format "%s #%d is ~.color and ~.taste" (fadr-member basket ".apples[1]") "Apple" 1)
  53 ;;     "Apple #1 is red and disgusting"
  54
  55 ;;; Code:
  56
  57 (defun fadr-get-field-value (field object)
  58   "Get value of FIELD from OBJECT.
  59
  60 FIELD is a symbol."
  61   (cdr (assoc field object)))
  62
  63 (defsubst bol-regexp (regexp)
  64   (concat "^" regexp))
  65 (defconst fadr-field-name-regexp
  66   "[[:alpha:]_-]+")
  67 (defconst fadr-field-selector-regexp
  68   (concat "\\.\\(" fadr-field-name-regexp "\\)"))
  69 (defconst fadr-index-selector-regexp
  70   "\\[\\([[:digit:]]+\\)\\]")
  71 (defconst fadr-path-regexp
  72   (concat "\\(" fadr-field-selector-regexp "\\|"
  73           fadr-index-selector-regexp
  74           "\\)+"))
  75
  76 (defmacro fadr-define-select (name regexp &optional doc filter)
  77   "Define a function NAME of one string argument which will
  78 extract data from it using the first subgroup in REGEXP. If
  79 FILTER is specified, it will be called with the resulting string."
  80   `(defun ,name (path)
  81      ,doc
  82      (let ((string (if (string-match ,regexp path)
  83                        (match-string-no-properties 1 path)
  84                      nil)))
  85        (if string
  86            ,(if filter
  87                 `(funcall ,filter string)
  88               'string)
  89          nil))))
  90
  91 (fadr-define-select fadr-index-select
  92   (bol-regexp fadr-index-selector-regexp)
  93   "Extract name of the next field selected in PATH as a symbol."
  94   'string-to-number)
  95
  96 ;; Bad case: (fadr-field-select ".nil")
  97 (fadr-define-select fadr-field-select
  98   (bol-regexp fadr-field-selector-regexp)
  99   "Extract value of the next list index selected in PATH as a
 100   number."
 101   'intern)
 102
 103 ;; TODO: define this function using macros to ease the adding of new
 104 ;; selector types
 105 (defun fadr-member (object path)
 106   "Access data in OBJECT using PATH.
 107
 108 This function is not match-safe, meaning that you may need to
 109 wrap a call to it with `save-match-data'."
 110   (if (string= path "")
 111       object
 112     (let ((index (fadr-index-select path))
 113           (field (fadr-field-select path)))
 114       (cond (index
 115              (fadr-member (elt object index)
 116                                     (fadr-peel-path path)))
 117             (field
 118              (fadr-member (fadr-get-field-value field object)
 119                                     (fadr-peel-path path)))
 120             (t (error "Bad path"))))))
 121
 122 (defun fadr-q (full-path)
 123   (catch 'bad-path
 124     (if (string-match fadr-path-regexp full-path)
 125         (if (not (= (match-beginning 0) 0))
 126             (let ((object (eval (intern (substring full-path 0 (match-beginning 0)))))
 127                   (path (substring full-path (match-beginning 0))))
 128               (fadr-member object path))
 129           (throw 'bad-path (error "No object specified")))
 130       (throw 'bad-path (error "Incorrect path")))))
 131
 132 (defun fadr-peel-path (path)
 133   "Return PATH without first selector."
 134   (cond ((fadr-field-select path)
 135          (string-match (bol-regexp fadr-field-selector-regexp) path))
 136         ((fadr-index-select path)
 137          (string-match (bol-regexp fadr-index-selector-regexp) path))
 138         (t (error "Could not peel path")))
 139   (substring path (match-end 0)))
 140
 141 (defun fadr-expand (string object)
 142   "Format STRING using OBJECT members.
 143
 144 All ~.<path> substrings within STRING are replaced with
 145 respective values of OBJECT members."
 146   (replace-regexp-in-string
 147    (concat "~\\(" fadr-path-regexp "\\)")
 148    #'(lambda (text)
 149        (save-match-data
 150          (format "%s"
 151                  (fadr-member object (substring text 1)))))
 152    string))
 153
 154 (defun fadr-format (string object &rest objects)
 155   "Format STRING with OBJECTS, then `fadr-expand' the result with OBJECT."
 156   (let ((new-string (apply 'format (append (list string) objects))))
 157     (fadr-expand new-string object)))
 158
 159 (provide 'fadr)
 160
 161 ;; arch-tag: 4edced02-a5c3-4516-b278-3f85a12146ea
 162 ;;; fadr.el ends here