code.delx.au - gnu-emacs-elpa/blob - packages/names/names-dev.el

   1 ;;; names-dev.el --- Developer Functions to facilitate use of names.el with your package.
   2
   3 ;; Copyright (C) 2014 Free Software Foundation, Inc.
   4
   5 ;; Prefix: names
   6 ;; Separator: -
   7
   8 ;;; Commentary:
   9 ;;
  10 ;; This package has some convenient functions for developers working
  11 ;; with names.el.
  12 ;; This package is installed along with names.el, but to use its
  13 ;; features you must require it explicitly:
  14 ;;
  15 ;;     (require 'names-dev)
  16
  17 ;;; License:
  18 ;;
  19 ;; This file is part of GNU Emacs.
  20 ;;
  21 ;; GNU Emacs is free software: you can redistribute it and/or modify
  22 ;; it under the terms of the GNU General Public License as published by
  23 ;; the Free Software Foundation, either version 3 of the License, or
  24 ;; (at your option) any later version.
  25 ;;
  26 ;; GNU Emacs is distributed in the hope that it will be useful,
  27 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  28 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  29 ;; GNU General Public License for more details.
  30 ;;
  31 ;; You should have received a copy of the GNU General Public License
  32 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  33
  34 ;;; Code:
  35
  36 (require 'names)
  37 (require 'elisp-mode nil t)
  38 (require 'lisp-mode nil t)
  39
  40 \f
  41 ;;; ---------------------------------------------------------------
  42 ;;; Developer Utility Functions
  43 (defmacro names-compare-forms (name form-a form-b)
  44   "Test if (namespace NAME FORM-A) is the same as FORM-B."
  45   (declare (indent (lambda (&rest x) 0))
  46            (debug (symbolp sexp form)))
  47   `(equal
  48     (macroexpand-all '(define-namespace ,name :global :verbose ,form-a))
  49     (macroexpand-all ',form-b)))
  50
  51 (defmacro names-compare-forms-assert (name form-a form-b)
  52   "Assert if (namespace NAME FORM-A) is the same as FORM-B."
  53   (declare (indent (lambda (&rest x) 0))
  54            (debug (symbolp sexp form)))
  55   (cl-assert
  56    (names-compare-forms name form-a form-b)
  57     t))
  58
  59 (defmacro names-print (name &rest forms)
  60   "Return the expanded results of (namespace NAME :global :verbose FORMS).
  61 Ideal for determining why a specific form isn't being parsed
  62 correctly. You may need to set `eval-expression-print-level' and
  63 `eval-expression-print-length' to nil in order to see your full
  64 expansion."
  65   (declare (indent (lambda (&rest x) 0)) (debug 0))
  66   `(define-namespace ,name :global :verbose ,@forms))
  67
  68 (defvar names-font-lock
  69   '(("^:autoload\\_>" 0 'font-lock-warning-face prepend)
  70     ("(\\(\\_<define-namespace\\_>\\)[\t \n]+\\([^\t \n]+\\)"
  71      (1 'font-lock-keyword-face)
  72      (2 'font-lock-variable-name-face))))
  73
  74 (when (boundp 'lisp-el-font-lock-keywords-2)
  75   (setq lisp-el-font-lock-keywords-2
  76         (append names-font-lock
  77                 lisp-el-font-lock-keywords-2)))
  78
  79 \f
  80 ;;; The backbone
  81 (defun names--looking-at-namespace ()
  82   "Non-nil if point is at a `define-namespace' form or an alias to it."
  83   (when (looking-at "(\\_<")
  84     (save-excursion
  85       (forward-char 1)
  86       (ignore-errors
  87         (equal (indirect-function (intern (thing-at-point 'symbol)))
  88                (indirect-function 'define-namespace))))))
  89
  90 (defun names--generate-new-buffer (name &optional form)
  91   "Generate and return a new buffer.
  92 NAME is current namespace name.
  93 If FORM is provided, also try to use it to decide an informative
  94 buffer name."
  95   (get-buffer-create
  96    (concat
  97     " *names "
  98     (format "%s %s"
  99             (or (car-safe form) (random 10000))
 100             (or (car-safe (cdr-safe form)) (random 10000)))
 101     "*")))
 102
 103 (defmacro names--wrapped-in-namespace (command form &optional kill &rest body)
 104   "Call COMMAND, except in a namespace.
 105 In a namespace, expand FORM in a separate buffer then execute
 106 BODY. If BODY is nil, call COMMAND instead.
 107 If KILL is non-nil, kill the temp buffer afterwards."
 108   (declare (indent defun)
 109            (debug (sexp form form body)))
 110   ;; Get the namespace, if we're in one.
 111   `(let ((evaled-form ,form)
 112          (invocation
 113           ',(if (commandp command t)
 114                 `(call-interactively #',command)
 115               command))
 116          (entire-namespace
 117           (save-excursion
 118             (when (names--top-of-namespace)
 119               (cdr (read (current-buffer))))))
 120          b keylist spec name expanded-form)
 121
 122      ;; If we're not in a namespace, call the regular `eval-defun'.
 123      (if (null entire-namespace)
 124          (eval invocation)
 125        ;; If we are, expand the function in a temp buffer
 126        (setq name (pop entire-namespace))
 127        (while (setq spec (names--next-keyword entire-namespace))
 128          (setq keylist (append keylist spec)))
 129        ;; Prepare the (possibly) temporary buffer.
 130        (setq b (names--generate-new-buffer name evaled-form))
 131        (unwind-protect
 132            (with-current-buffer b
 133              (cl-letf (((symbol-function #'message) #'ignore))
 134                (erase-buffer)
 135                (emacs-lisp-mode)
 136                ;; Print everything inside the `progn'.
 137                (mapc
 138                 (lambda (it) (pp it (current-buffer)))
 139                 (cdr
 140                  (setq expanded-form
 141                        (macroexpand
 142                         `(define-namespace ,name :global :clean-output ,@keylist ,evaled-form)))))
 143                (when (fboundp 'font-lock-ensure)
 144                  (font-lock-ensure)))
 145              ;; Return value
 146              ,@(or body '((eval invocation))))
 147          ;; Kill the buffer if we won't need it.
 148          (when (and ,kill (buffer-live-p b))
 149            (kill-buffer b))))))
 150
 151 (defun names--top-of-namespace ()
 152   "Move to the top of current namespace, and return non-nil.
 153 If not inside a namespace, return nil and don't move point."
 154   (let ((top (save-excursion
 155                (beginning-of-defun)
 156                (ignore-errors
 157                  (backward-up-list))
 158                (when (names--looking-at-namespace)
 159                  (point)))))
 160     (when top
 161       (goto-char top)
 162       t)))
 163
 164 (defun names-eval-defun (edebug-it)
 165   "Identical to `eval-defun', except it works for forms inside namespaces.
 166 Argument EDEBUG-IT is the same as `eval-defun', causes the form
 167 to be edebugged."
 168   (interactive "P")
 169   (require 'font-lock) ; just in case
 170   (let ((form
 171          (save-excursion
 172            (end-of-defun)
 173            (beginning-of-defun)
 174            (read (current-buffer)))))
 175     (names--wrapped-in-namespace
 176       eval-defun form (null edebug-it))))
 177
 178 \f
 179 ;;; eval-last-sexp
 180 (defalias 'names--preceding-sexp-original
 181   (if (fboundp 'elisp--preceding-sexp)
 182       (symbol-function 'elisp--preceding-sexp)
 183     (symbol-function 'preceding-sexp)))
 184
 185 (defun names--preceding-sexp ()
 186   "Like `elisp--preceding-sexp', but expand namespaces."
 187   (names--wrapped-in-namespace
 188     (names--preceding-sexp-original) (names--preceding-sexp-original) t
 189     expanded-form))
 190
 191 (defun names-eval-last-sexp (eval-last-sexp-arg-internal)
 192   "Identical to `eval-last-sexp', except it works for forms inside namespaces.
 193 Argument EVAL-LAST-SEXP-ARG-INTERNAL is the same as `eval-last-sexp'."
 194   (interactive "P")
 195   (cl-letf (((symbol-function 'elisp--preceding-sexp) #'names--preceding-sexp)
 196             ((symbol-function 'preceding-sexp) #'names--preceding-sexp))
 197     (eval-last-sexp eval-last-sexp-arg-internal)))
 198
 199 (defun names-eval-print-last-sexp (eval-last-sexp-arg-internal)
 200   "Identical to `eval-print-last-sexp', except it works for forms inside namespaces.
 201 Argument EVAL-LAST-SEXP-ARG-INTERNAL is the same as `eval-print-last-sexp'."
 202   (interactive "P")
 203   (cl-letf (((symbol-function 'elisp--preceding-sexp) #'names--preceding-sexp)
 204             ((symbol-function 'preceding-sexp) #'names--preceding-sexp))
 205     (eval-print-last-sexp eval-last-sexp-arg-internal)))
 206
 207 ;; (pp (symbol-function 'names--preceding-sexp-original) (current-buffer))
 208
 209 (defun names-pprint ()
 210   "Pretty-print an expansion of the namespace around point."
 211   (interactive)
 212   (save-excursion
 213     (when (names--top-of-namespace)
 214       (let ((ns (cdr (read (current-buffer)))))
 215         (pp-macroexpand-expression
 216          (macroexpand (cons 'names-print ns)))))))
 217
 218 \f
 219 ;;; Find stuff
 220 (require 'find-func nil t)
 221 (defalias 'names--fboundp-original (symbol-function 'fboundp))
 222 (defalias 'names--boundp-original (symbol-function 'boundp))
 223 (defalias 'names--find-function-read-original (symbol-function 'find-function-read))
 224 (defalias 'find-function-read 'names--find-function-read)
 225
 226 (defun names--find-function-read (&optional type)
 227   "Identical to `find-function-read', except it works inside namespaces."
 228   (let ((buf (current-buffer)))
 229     (names--wrapped-in-namespace
 230       (names--find-function-read-original type) nil t
 231       (set-buffer buf)
 232       (let ((names--name name))
 233         (cl-letf (((symbol-function 'fboundp) #'names--dev-fboundp)
 234                   ((symbol-function 'boundp) #'names--dev-boundp))
 235           (names--find-function-read-original type))))))
 236
 237 (defun names--dev-fboundp (sym)
 238   (or (names--fboundp-original sym)
 239       (names--fboundp-original (names--prepend sym))))
 240 (defun names--dev-boundp (sym)
 241   (or (names--boundp-original sym)
 242       (names--boundp-original (names--prepend sym))))
 243
 244 \f
 245 ;;; The keys
 246 (eval-after-load 'lisp-mode
 247   '(let ((map emacs-lisp-mode-map))
 248      (define-key map [remap eval-defun] #'names-eval-defun)
 249      (define-key map [remap eval-last-sexp] #'names-eval-last-sexp)
 250      (define-key map [remap eval-print-last-sexp] #'names-eval-print-last-sexp)))
 251
 252 (provide 'names-dev)
 253
 254 ;;; names-dev.el ends here