1 ;;; names-dev.el --- Developer Functions to facilitate use of names.el with your package.
3 ;; Copyright (C) 2014 Free Software Foundation, Inc.
10 ;; This package has some convenient functions for developers working
12 ;; This package is installed along with names.el, but to use its
13 ;; features you must require it explicitly:
15 ;; (require 'names-dev)
19 ;; This file is part of GNU Emacs.
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.
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.
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/>.
37 (require 'elisp-mode nil t)
38 (require 'lisp-mode nil t)
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)))
48 (macroexpand-all '(define-namespace ,name :global :verbose ,form-a))
49 (macroexpand-all ',form-b)))
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)))
56 (names-compare-forms name form-a form-b)
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
65 (declare (indent (lambda (&rest x) 0)) (debug 0))
66 `(define-namespace ,name :global :verbose ,@forms))
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))))
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)))
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 "(\\_<")
87 (equal (indirect-function (intern (thing-at-point 'symbol)))
88 (indirect-function 'define-namespace))))))
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
99 (or (car-safe form) (random 10000))
100 (or (car-safe (cdr-safe form)) (random 10000)))
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)
113 ',(if (commandp command t)
114 `(call-interactively #',command)
118 (when (names--top-of-namespace)
119 (cdr (read (current-buffer))))))
120 b keylist spec name expanded-form)
122 ;; If we're not in a namespace, call the regular `eval-defun'.
123 (if (null entire-namespace)
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))
132 (with-current-buffer b
133 (cl-letf (((symbol-function #'message) #'ignore))
136 ;; Print everything inside the `progn'.
138 (lambda (it) (pp it (current-buffer)))
142 `(define-namespace ,name :global :clean-output ,@keylist ,evaled-form)))))
143 (when (fboundp 'font-lock-ensure)
146 ,@(or body '((eval invocation))))
147 ;; Kill the buffer if we won't need it.
148 (when (and ,kill (buffer-live-p b))
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
158 (when (names--looking-at-namespace)
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
169 (require 'font-lock) ; just in case
174 (read (current-buffer)))))
175 (names--wrapped-in-namespace
176 eval-defun form (null edebug-it))))
180 (defalias 'names--preceding-sexp-original
181 (if (fboundp 'elisp--preceding-sexp)
182 (symbol-function 'elisp--preceding-sexp)
183 (symbol-function 'preceding-sexp)))
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
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'."
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)))
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'."
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)))
207 ;; (pp (symbol-function 'names--preceding-sexp-original) (current-buffer))
209 (defun names-pprint ()
210 "Pretty-print an expansion of the namespace around point."
213 (when (names--top-of-namespace)
214 (let ((ns (cdr (read (current-buffer)))))
215 (pp-macroexpand-expression
216 (macroexpand (cons 'names-print ns)))))))
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)
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
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))))))
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))))
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)))
254 ;;; names-dev.el ends here