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."
  66   (declare (indent (lambda (&rest x) 0)) (debug 0))
  67   `(let ((eval-expression-print-level (max eval-expression-print-level 300))
  68          (eval-expression-print-length (max eval-expression-print-length 300)))
  69      (macroexpand '(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   ""
 156   (progn
 157     (beginning-of-defun)
 158     (ignore-errors
 159       (backward-up-list)
 160       (names--looking-at-namespace))))
 161
 162 (defun names-eval-defun (edebug-it)
 163   "Identical to `eval-defun', except it works for forms inside namespaces.
 164 Argument EDEBUG-IT is the same as `eval-defun', causes the form
 165 to be edebugged."
 166   (interactive "P")
 167   (require 'font-lock) ; just in case
 168   (let ((form
 169          (save-excursion
 170            (end-of-defun)
 171            (beginning-of-defun)
 172            (read (current-buffer)))))
 173     (names--wrapped-in-namespace
 174       eval-defun form (null edebug-it))))
 175
 176 \f
 177 ;;; eval-last-sexp
 178 (defalias 'names--preceding-sexp-original
 179   (symbol-function 'elisp--preceding-sexp))
 180
 181 (defun names--preceding-sexp ()
 182   "Like `elisp--preceding-sexp', but expand namespaces."
 183   (names--wrapped-in-namespace
 184     (names--preceding-sexp-original) (names--preceding-sexp-original) t
 185     expanded-form))
 186
 187 (defun names-eval-last-sexp (eval-last-sexp-arg-internal)
 188   "Identical to `eval-last-sexp', except it works for forms inside namespaces.
 189 Argument EVAL-LAST-SEXP-ARG-INTERNAL is the same as `eval-last-sexp'."
 190   (interactive "P")
 191   (cl-letf (((symbol-function 'elisp--preceding-sexp)
 192              #'names--preceding-sexp))
 193     (eval-last-sexp eval-last-sexp-arg-internal)))
 194
 195 (defun names-eval-print-last-sexp (eval-last-sexp-arg-internal)
 196   "Identical to `eval-print-last-sexp', except it works for forms inside namespaces.
 197 Argument EVAL-LAST-SEXP-ARG-INTERNAL is the same as `eval-print-last-sexp'."
 198   (interactive "P")
 199   (cl-letf (((symbol-function 'elisp--preceding-sexp)
 200              #'names--preceding-sexp))
 201     (eval-print-last-sexp eval-last-sexp-arg-internal)))
 202
 203 ;; (pp (symbol-function 'names-eval-defun) (current-buffer))
 204
 205 \f
 206 ;;; Find stuff
 207 (require 'find-func nil t)
 208 (defalias 'names--fboundp-original (symbol-function 'fboundp))
 209 (defalias 'names--boundp-original (symbol-function 'boundp))
 210 (defalias 'names--find-function-read-original (symbol-function 'find-function-read))
 211 (defalias 'find-function-read 'names--find-function-read)
 212
 213 (defun names--find-function-read (&optional type)
 214   "Identical to `find-function-read', except it works inside namespaces."
 215   (let ((buf (current-buffer)))
 216     (names--wrapped-in-namespace
 217       (names--find-function-read-original type) nil t
 218       (set-buffer buf)
 219       (let ((names--name name))
 220         (cl-letf (((symbol-function 'fboundp) #'names--dev-fboundp)
 221                   ((symbol-function 'boundp) #'names--dev-boundp))
 222           (names--find-function-read-original type))))))
 223
 224 (defun names--dev-fboundp (sym)
 225   (or (names--fboundp-original sym)
 226       (names--fboundp-original (names--prepend sym))))
 227 (defun names--dev-boundp (sym)
 228   (or (names--boundp-original sym)
 229       (names--boundp-original (names--prepend sym))))
 230
 231 \f
 232 ;;; The keys
 233 (eval-after-load 'lisp-mode
 234   '(let ((map emacs-lisp-mode-map))
 235      (define-key map [remap eval-defun] #'names-eval-defun)
 236      (define-key map [remap eval-last-sexp] #'names-eval-last-sexp)
 237      (define-key map [remap eval-print-last-sexp] #'names-eval-print-last-sexp)))
 238
 239 (provide 'names-dev)
 240
 241 ;;; names-dev.el ends here