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