--- /dev/null
+;;; names.el --- Namespaces for emacs-lisp. Avoid name clobbering without hiding symbols.
+
+;; Copyright (C) 2014 Free Software Foundation, Inc.
+
+;; Author: Artur Malabarba <bruce.connor.am@gmail.com>
+;; Maintainer: Artur Malabarba <bruce.connor.am@gmail.com>
+;; URL: http://github.com/Bruce-Connor/names
+;; Version: 0
+;; Package-Requires: ((emacs "24.1") (cl-lib "0.5"))
+;; Keywords: extensions lisp
+;; Prefix: names
+;; Separator: -
+
+;;; Commentary:
+;;
+;; The description is way too large to sanely write here, below is a
+;; summary. For a complete description, please visit the package's
+;; frontpage with `M-x names-view-manual', or see the Readme file on
+;; https://raw.githubusercontent.com/Bruce-Connor/names/master/Readme.org
+
+;;; License:
+;;
+;; This file is part of GNU Emacs.
+;;
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+;;
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; News:
+;;; Code:
+\f
+
+(require 'cl-lib)
+(require 'edebug)
+(require 'bytecomp)
+(require 'advice)
+
+;;; Support
+(declare-function names--autoload-do-load "names" 2)
+(if (fboundp 'function-get)
+ (defalias 'names--function-get #'function-get)
+ (defun names--function-get (f prop &rest _)
+ "Return the value of property PROP of function F.
+If F is an autoloaded macro, try to autoload it in the hope that
+it will set PROP."
+ (let ((val nil))
+ (while (and (symbolp f)
+ (null (setq val (get f prop)))
+ (fboundp f))
+ (let ((fundef (symbol-function f)))
+ (if (and (names--autoloadp fundef)
+ (not (equal fundef (names--autoload-do-load fundef f))))
+ nil ;Re-try `get' on the same `f'.
+ (setq f fundef))))
+ val))
+ (defun names--autoload-do-load (def name)
+ "Load autoloaded definition DEF from function named NAME."
+ (unless (load (cadr def) 'noerror)
+ (error "Macro `%s' is autoloaded, but its file (%s) couldn't be loaded"
+ name (cadr def)))
+ (symbol-function name)))
+
+(if (fboundp 'macrop)
+ (defalias 'names--compat-macrop #'macrop)
+ (defun names--compat-macrop (object)
+ "Non-nil if and only if OBJECT is a macro."
+ (let ((def (indirect-function object t)))
+ (when (consp def)
+ (or (eq 'macro (car def))
+ (and (names--autoloadp def) (memq (nth 4 def) '(macro t))))))))
+
+(if (fboundp 'autoloadp)
+ (defalias 'names--autoloadp #'autoloadp)
+ (defsubst names--autoloadp (object)
+ "Non-nil if OBJECT is an autoload."
+ (eq 'autoload (car-safe object))))
+
+(unless (get-edebug-spec 'cl-defun)
+ (def-edebug-spec cl-defun defun*))
+(unless (get-edebug-spec 'cl-defmacro)
+ (def-edebug-spec cl-defmacro defmacro*))
+(unless (get-edebug-spec 'setq-local)
+ (def-edebug-spec setq-local setq))
+(unless (get-edebug-spec 'loop)
+ (def-edebug-spec loop
+ (&rest &or
+ ;; These are usually followed by a symbol, but it can
+ ;; actually be any destructuring-bind pattern, which
+ ;; would erroneously match `form'.
+ [[&or "for" "as" "with" "and"] sexp]
+ ;; These are followed by expressions which could
+ ;; erroneously match `symbolp'.
+ [[&or "from" "upfrom" "downfrom" "to" "upto" "downto"
+ "above" "below" "by" "in" "on" "=" "across"
+ "repeat" "while" "until" "always" "never"
+ "thereis" "collect" "append" "nconc" "sum"
+ "count" "maximize" "minimize" "if" "unless"
+ "return"] form]
+ ;; Simple default, which covers 99% of the cases.
+ symbolp form)))
+
+\f
+;;; ---------------------------------------------------------------
+;;; Variables
+(defconst names-version "0.5.5" "Version of the names.el package.")
+
+(defvar names--name nil
+ "Name of the current namespace inside the `define-namespace' macro.")
+(defvar names--regexp nil "Regexp matching `names--name'.")
+
+(defvar names--load-file (and load-file-name (expand-file-name load-file-name))
+ "The file where the current version of Names was loaded.
+This is used by `names--check-for-update' to check if a new
+version has been installed.")
+
+(defvar names--bound nil
+ "List of variables defined in this namespace.")
+(defvar names--fbound nil
+ "List of functions defined in this namespace.")
+(defvar names--macro nil
+ "List of macros defined in this namespace.")
+
+(defvar names--keywords nil
+ "Keywords that were passed to the current namespace.
+See `names--keyword-list' for a list and description of possible
+keywords.")
+
+(defvar names--local-vars nil
+ "Non-global vars that are let/lambda bound at the moment.
+These won't be namespaced, as local takes priority over namespace.")
+
+(defvar names--protection nil
+ "Leading chars used to identify protected symbols.
+Don't customise this.
+Instead use the :protection keyword when defining the
+namespace.")
+
+(defvar names--current-run nil
+ "Either 1 or 2, depending on which runthrough we're in.")
+
+(defvar names--var-list
+ '(names--name names--regexp names--bound
+ names--version
+ names--package names--group-parent
+ names--macro names--current-run
+ names--fbound names--keywords
+ names--local-vars names--protection)
+ "List of variables the user shouldn't touch.")
+
+;;;###autoload
+(defvar names--inside-make-autoload nil
+ "Used in `make-autoload' to indicate we're making autoloads.")
+
+(defvar names--package nil
+ "Package, name to be used by the :group and :version keywords.
+Is derived from `load-file-name', unless the :package keyword is
+passed to `define-namespace'.")
+
+(defvar names--group-parent nil
+ "The name of the parent to be given to `defgroup'.
+Is only non-nil if the :group keyword is passed to `define-namespace'.")
+
+(defvar names--version nil
+ "The version number given by :version.
+Used to define a constant and a command.")
+
+(defconst names--keyword-list
+ '((:group
+ 1 (lambda (x)
+ (if (symbolp x)
+ (setq names--group-parent x)
+ (names--warn
+ "Argument given to :group is not a symbol: %s" x)))
+ "Indicate `define-namespace' should make a `defgroup' for you.
+The name of the group is the package name (see :package keyword).
+This keyword should be given one argument, the name of the PARENT
+group as an unquoted symbol.
+
+If this keyword is provided, besides including a defgroup, Names
+will also include a :group keyword in every `defcustom' (and
+similar forms) that don't already contain one.")
+
+ (:version
+ 1
+ (lambda (x)
+ (if (stringp x)
+ (setq names--version x)
+ (names--warn
+ "Argument given to :version is not a string: %s" x)))
+ "Indicate `define-namespace' should define the version number.
+This keyword should be given one argument, a string describing
+the package's version number.
+
+With this, Names will generate a `defconst' and an interactive
+`defun', each named `PACKAGE-NAME-version'. The function messages
+and returns the version number. See the :package keyword.")
+
+ (:package
+ 1
+ (lambda (x)
+ (if (symbolp x)
+ (setq names--package x)
+ (names--warn
+ "Argument given to :package is not a symbol: %s" x)))
+ "Set the name of this package to the given symbol.
+This keyword should be given one argument, a symbol corresponding
+to the name of this package.
+
+If this keyword isn't used, the package name is taken as the the
+file's basename, but only if its actually needed. This name is
+needed by the :version and :group keywords.")
+
+ (:protection
+ 1
+ (lambda (x)
+ (let ((val (symbol-name x)))
+ (setq names--protection
+ (format "\\`%s" (regexp-quote val)))))
+ "Change the value of the `names--protection' variable.")
+
+ (:no-let-vars
+ 0 nil
+ "Indicates variables assigned in let-bind are NOT candidates for namespacing.")
+
+ (:verbose
+ 0 nil
+ "Cause a message to be called on each special form.")
+
+ (:global
+ 0 nil
+ "Accept namespaced names from outside current namespace definition.")
+
+ (:assume-var-quote
+ 0 nil
+ "Indicate symbols quoted with `quote' should be considered variable names.")
+
+ (:dont-assume-function-quote
+ 0 nil
+ "Indicate symbols quoted with `function' should NOT be considered function names.")
+
+ (:clean-output
+ 0 nil
+ "Indicate only forms actually inside the namespace should be present in the output.
+This is for internal use. It is used by `names-eval-defun' to
+prevent `define-namespace' from adding things like `defgroup' or
+`defconst's to the output."))
+ "List of keywords used by `define-namespace'.
+Each element is a list containing
+ (KEYWORD N DEFINITION DOCUMENTATION)
+where:
+
+- KEYWORD is the keyword's name, a symbol satifying `keywordp'.
+- N is the number of arguments it takes, an integer.
+- DEFINITION is a function (symbol or lambda) that takes N
+arguments and does whatever you need for implementing the
+keyword.
+- DOCUMENTATION is a string explaining the keyword's
+behaviour.")
+
+(defmacro names--prepend (sbl)
+ "Return namespace+SBL."
+ (declare (debug (symbolp)))
+ `(intern (format "%s%s" names--name ,sbl)))
+
+
+(defmacro names--filter-if-bound (var &optional pred)
+ "If VAR is bound and is a list, take the car of its elements which satify PRED."
+ (declare (debug (symbolp &optional function-form)))
+ `(when (boundp ',var)
+ (remove
+ nil
+ (mapcar (lambda (x) (when (funcall (or ,pred 'identity) (or (car-safe x) x))
+ (or (car-safe x) x)))
+ ,var))))
+
+(defmacro names--next-keyword (body)
+ "If car of BODY is a known keyword, `pop' it (and its arguments) from body.
+Returns a list (KEYWORD . ARGUMENTLIST)."
+ (declare (debug sexp))
+ `(let ((kar (car-safe ,body))
+ out n)
+ (and kar
+ (keywordp kar)
+ (setq n (assoc kar names--keyword-list))
+ (setq n (cadr n))
+ (dotimes (it (1+ n) out)
+ (push (pop ,body) out))
+ (nreverse out))))
+
+(defvar names--has-reloaded nil
+ "Whether `names--reload-if-upgraded' has already been called in this run.")
+
+\f
+;;; ---------------------------------------------------------------
+;;; The Main Macro and Main Function.
+;;;###autoload
+(defmacro define-namespace (name &rest body)
+ "Inside the namespace NAME, execute BODY.
+NAME can be any symbol (not quoted), but it's highly recommended
+to use some form of separator (such as :, /, or -). For a
+complete description of this macro, please visit the frontpage
+with \\[names-view-manual].
+
+In summary, this macro has two main effects:
+
+1. Any definitions inside BODY will have NAME prepended to the
+symbol given. Ex:
+
+ (define-namespace foo-
+ (defvar bar 1 \"docs\")
+ )
+
+expands to
+
+ (defvar foo-bar 1 \"docs\")
+
+
+2. Any function calls and variable names get NAME prepended to
+them if such a variable or function exists. Ex:
+
+ (define-namespace foo:
+ (defun message (x y) nil)
+ (message \"%s\" my-var)
+ )
+
+expands to
+
+ (defun foo:message (x y) nil)
+ (foo:message \"%s\" my-var)
+
+Note how `message' is expanded to `foo:message' in the second
+form, because that function exists. Meanwhile, `bar' is left
+untouched because `foo:bar' is not a known variable name.
+
+===============================
+
+AUTOLOAD
+
+In order for `define-namespace' to work with \";;;###autoload\"
+comments must replace all instances of \";;;###autoload\" inside
+your `define-namespace' with `:autoload'.
+Afterwards, add an \";;;###autoload\" comment just above your
+`define-namespace'.
+
+===============================
+
+KEYWORDS
+
+Immediately after NAME you may add keywords which customize the
+behaviour of `define-namespace'. For a list of possible keywords
+and a description of their effects, see the variable
+`names--keyword-list'.
+
+\(fn NAME [KEYWORD ...] BODY)"
+ (declare (indent (lambda (&rest x) 0))
+ (debug (&define name [&rest keywordp &optional [&or symbolp (symbolp . symbolp)]] body)))
+ (let ((names--has-reloaded names--has-reloaded))
+ ;; This was to avoid an infinite recursion, but the bug turned out
+ ;; to be somewhere else. Still, I see no reason to erase this.
+ (unless names--has-reloaded
+ (setq names--has-reloaded t)
+ (names--reload-if-upgraded))
+ (names--error-if-using-vars)
+ (names--define-namespace-implementation name body)))
+
+(defun names--define-namespace-implementation (name body)
+ "Namespace BODY using NAME.
+See `define-namespace' for more information."
+ (unwind-protect
+ (let* ((names--name name)
+ (names--regexp
+ (concat "\\`" (regexp-quote (symbol-name name))))
+ (names--current-run 0)
+ ;; Use the :protection keyword to change this.
+ (names--protection "\\`::")
+ (names--bound
+ (names--remove-namespace-from-list
+ (names--filter-if-bound byte-compile-bound-variables)
+ (names--filter-if-bound byte-compile-variables)))
+ (names--fbound
+ (names--remove-namespace-from-list
+ (names--filter-if-bound byte-compile-macro-environment 'names--compat-macrop)
+ (names--filter-if-bound byte-compile-function-environment 'names--compat-macrop)))
+ (names--macro
+ (names--remove-namespace-from-list
+ (names--filter-if-bound byte-compile-macro-environment (lambda (x) (not (names--compat-macrop x))))
+ (names--filter-if-bound byte-compile-function-environment (lambda (x) (not (names--compat-macrop x))))))
+ names--keywords names--local-vars key-and-args
+ names--version names--package names--group-parent)
+ ;; Read keywords
+ (while (setq key-and-args (names--next-keyword body))
+ (names--handle-keyword key-and-args)
+ (push key-and-args names--keywords))
+
+ ;; First have to populate the bound and fbound lists. So we read
+ ;; the entire form (without evaluating it).
+ (mapc 'names-convert-form body)
+ (setq names--current-run (1+ names--current-run))
+
+ ;; Then we go back and actually namespace the entire form, which
+ ;; we'll later return so that it can be evaluated.
+ (setq body
+ (cons
+ 'progn
+ (append
+ (when (and names--group-parent
+ (null (names--keyword :clean-output)))
+ (list (names--generate-defgroup)))
+ (when (and names--version
+ (null (names--keyword :clean-output)))
+ ;; `names--generate-version' returns a list.
+ (names--generate-version))
+ (mapcar 'names-convert-form
+ ;; Unless we're in `make-autoload', then just return autoloads.
+ (if names--inside-make-autoload
+ (names--extract-autoloads body)
+ body)))))
+
+ ;; On emacs-version < 24.4, the byte-compiler cannot expand a
+ ;; macro if it is being called in the same top-level form as
+ ;; it was defined. That's a problem for us, since the entire
+ ;; namespace is a single top-level form (we return a `progn').
+ ;; The solution is for us to add the macros to
+ ;; `byte-compile-macro-environment' ourselves.
+ (if (and (boundp 'byte-compile-current-buffer)
+ byte-compile-current-buffer
+ (null names--inside-make-autoload)
+ (version< emacs-version "24.4"))
+ (let ((byte-compile-macro-environment
+ (when (boundp 'byte-compile-macro-environment)
+ byte-compile-macro-environment)))
+ (mapc #'names--add-macro-to-environment (cdr body))
+ (macroexpand-all body byte-compile-macro-environment))
+ body))
+
+ ;; Exiting the `unwind-protect'.
+ (mapc (lambda (x) (set x nil)) names--var-list)))
+
+(defun names--reload-if-upgraded ()
+ "Verify if there's a more recent version of Names in the `load-path'.
+If so, evaluate it."
+ (ignore-errors
+ (require 'find-func)
+ (let ((lp (expand-file-name (find-library-name "names")))
+ new-version)
+ (when (and lp
+ (not (string= lp names--load-file))
+ (file-readable-p lp))
+ (with-temp-buffer
+ (insert-file-contents-literally lp)
+ (goto-char (point-min))
+ (setq new-version
+ (save-excursion
+ (when (search-forward-regexp
+ "(defconst\\s-+names-version\\s-+\"\\([^\"]+\\)\"" nil t)
+ (match-string-no-properties 1))))
+ (when (and new-version (version< names-version new-version))
+ (eval-buffer nil lp)))))))
+
+(defun names-convert-form (form)
+ "Do namespace conversion on FORM.
+FORM is any legal elisp form.
+Namespace name is defined by the global variable `names--name'.
+
+See macro `namespace' for more information."
+ (cond
+ ((null form) form)
+ ;; Function calls
+ ((consp form)
+ (let ((kar (car form))
+ func)
+ (cond
+ ;; If symbol is protected, clean it.
+ ((and (symbolp kar)
+ (setq func (names--remove-protection kar)))
+ (names--message "Protected: %s" kar)
+ ;; And decide what to do with it.
+ (names--handle-args func (cdr form)))
+
+ ;; If kar is a list, either 1) it's a lambda form, 2) it's a
+ ;; macro we don't know about yet, 3) we have a bug.
+ ((consp kar)
+ (when (and (null (functionp kar))
+ (> names--current-run 1))
+ (names--warn "Ran into the following strange form.
+Either it's an undefined macro, a macro with a bad debug declaration, or we have a bug.\n%s" form))
+ (mapcar 'names-convert-form form))
+
+ ;; Namespaced Functions/Macros
+ ((names--fboundp kar)
+ (names--message "Namespaced: %s" kar)
+ (names--args-of-function-or-macro
+ (names--prepend kar) (cdr form) (names--macrop kar)))
+
+ ;; General functions/macros/special-forms
+ (t (names--handle-args kar (cdr form))))))
+ ;; Variables
+ ((symbolp form)
+ (names--message "Symbol handling: %s" form)
+ ;; If symbol is protected, clean it and don't namespace it.
+ (or (names--remove-protection form)
+ ;; Otherwise, namespace if possible.
+ (if (names--boundp form)
+ (names--prepend form)
+ form)))
+ ;; Values
+ (t form)))
+
+\f
+;;; ---------------------------------------------------------------
+;;; Some auxiliary functions
+(defun names-view-manual ()
+ "Call `browse-url' to view the manual of the Names package."
+ (interactive)
+ (browse-url "http://github.com/Bruce-Connor/names"))
+
+(defun names--package-name ()
+ "Return the package name as a symbol.
+Decide package name based on several factors. In order:
+ 1. The :package keyword,
+ 2. The namespace NAME, removing the final char."
+ (or names--package
+ (let ((package (symbol-name names--name)))
+ (prog1 (setq names--package
+ (intern (substring package 0 -1)))
+ (names--warn "No :package given. Guessing `%s'"
+ names--package)))))
+
+(defun names--generate-defgroup ()
+ "Return a `defgroup' form for the current namespace."
+ (list 'defgroup (names--package-name) nil
+ (format "Customization group for %s." (names--package-name))
+ :prefix (symbol-name names--name)
+ :group `',names--group-parent))
+
+(defun names--generate-version ()
+ "Return a `defun' and a `defconst' forms declaring the package version.
+Also adds `version' to `names--fbound' and `names--bound'."
+ (add-to-list 'names--fbound 'version)
+ (add-to-list 'names--bound 'version)
+ (list
+ (list 'defconst (names--prepend 'version)
+ names--version
+ (format "Version of the %s package." (names--package-name)))
+ (list 'defun (names--prepend 'version) nil
+ (format "Version of the %s package." (names--package-name))
+ '(interactive)
+ names--version)))
+
+(defun names--add-macro-to-environment (form)
+ "If FORM declares a macro, add it to `byte-compile-macro-environment'."
+ (let ((expansion form))
+ (while (names--compat-macrop (car-safe expansion))
+ (setq expansion
+ (ignore-errors (macroexpand
+ expansion byte-compile-macro-environment))))
+ (and expansion
+ (car-safe expansion)
+ (or (and (memq (car-safe expansion) '(progn prog1 prog2))
+ (mapc #'names--add-macro-to-environment (cdr expansion)))
+ (and (eq 'defalias (car-safe expansion))
+ (let ((def (ignore-errors (eval (nth 2 expansion)))))
+ (and (names--compat-macrop def)
+ (push (cons (ignore-errors
+ (eval (nth 1 expansion)))
+ (cdr-safe def))
+ byte-compile-macro-environment))))))))
+
+(defun names--extract-autoloads (body)
+ "Return a list of the forms in BODY preceded by :autoload."
+ (let (acons)
+ (when (setq acons (memq :autoload body))
+ (cons
+ (cadr acons)
+ (names--extract-autoloads (cdr (cdr acons)))))))
+
+;;;###autoload
+(defadvice make-autoload (around names-before-make-autoload-advice
+ (form file &optional expansion) activate)
+ "Make sure `make-autoload' understands `define-namespace'.
+Use the `names--inside-make-autoload' variable to indicate to
+`define-namespace' that we're generating autoloads."
+ ;; We used to have a letbind here, but this was causing a void
+ ;; variable bug on Emacs 24.3.
+ (require 'names)
+ (if (null (eq (car-safe form) 'define-namespace))
+ ad-do-it
+ (setq names--inside-make-autoload t)
+ (setq form (macroexpand form))
+ (setq names--inside-make-autoload nil)
+ ;; Up to 24.2 `make-autoload' couldn't handle `progn's.
+ (if (version< emacs-version "24.3")
+ (setq ad-return-value
+ (cons 'progn
+ (mapcar (lambda (x) (names--make-autoload-compat x file))
+ (cdr form))))
+ (ad-set-arg 2 'expansion)
+ (ad-set-arg 0 form)
+ ad-do-it)))
+
+(defun names--make-autoload-compat (form file)
+ (if (eq (car-safe form) 'defalias)
+ form
+ (make-autoload form file)))
+
+(defvar names--ignored-forms '(declare)
+ "The name of functions/macros/special-forms which we return without reading.")
+
+(defun names--handle-args (func args)
+ "Generic handling for the form (FUNC . ARGS), without namespacing FUNC."
+ (if (memq func names--ignored-forms)
+ (cons func args)
+ ;; TODO: Speed this up. Just change it to an alist or a hash-table.
+ (let ((handler (intern-soft (format "names--convert-%s" func))))
+ ;; Some function-like forms get special handling.
+ ;; That's anything with a names--convert-%s function defined.
+ (if (fboundp handler)
+ (progn (names--message "Special handling: %s" handler)
+ (funcall handler (cons func args)))
+ ;; If it isn't special, it's either a function or a macro.
+ (names--args-of-function-or-macro func args (names--compat-macrop func))))))
+
+(defun names--message (f &rest rest)
+ "If :verbose is on, pass F and REST to `message'."
+ (when (names--keyword :verbose)
+ (apply 'message (concat "[names] " f) rest)))
+
+(defun names--warn (f &rest rest)
+ "Pass F and REST to `message', unless byte-compiling or non-interactive."
+ (unless (and (null (names--keyword :verbose))
+ (and (boundp 'byte-compile-function-environment)
+ byte-compile-function-environment))
+ (apply 'message (concat "[names] " f) rest)))
+
+(defun names--error-if-using-vars ()
+ "Remind the developer that variables are not customizable."
+ (mapcar
+ (lambda (x)
+ (when (eval x)
+ (error "[names] Global value of variable %s should be nil! %s"
+ x "Set it using keywords instead")))
+ names--var-list))
+
+(defun names--remove-namespace-from-list (&rest lists)
+ "Return a concatenated un-namespaced version of LISTS.
+Symbols in LISTS that aren't namespaced are removed, symbols that
+are namespaced become un-namespaced."
+ (delq nil (mapcar 'names--remove-namespace (apply 'append lists))))
+
+(defun names--remove-namespace (symbol)
+ "Return SYMBOL with namespace removed, or nil if S wasn't namespaced."
+ (names--remove-regexp symbol names--regexp))
+
+(defun names--remove-protection (symbol)
+ "Remove the leading :: from SYMBOL if possible, otherwise return nil."
+ (names--remove-regexp symbol names--protection))
+
+(defun names--remove-regexp (s r)
+ "Return S with regexp R removed, or nil if S didn't match."
+ (let ((name (symbol-name s)))
+ (when (string-match r name)
+ (intern (replace-match "" nil nil name)))))
+
+(defun names--quote-p (sbl)
+ "Is SBL a function which quotes its argument?"
+ (memq sbl '(quote function)))
+
+(defun names--fboundp (sbl)
+ "Is namespace+SBL a fboundp symbol?"
+ (or (memq sbl names--fbound)
+ (memq sbl names--macro)
+ (and (names--keyword :global)
+ (fboundp (names--prepend sbl)))))
+
+(defun names--macrop (sbl)
+ "Is namespace+SBL a fboundp symbol?"
+ (or (memq sbl names--macro)
+ (and (names--keyword :global)
+ (names--compat-macrop (names--prepend sbl)))))
+
+(defun names--keyword (keyword)
+ "Was KEYWORD one of the keywords passed to the `namespace' macro?"
+ (assoc keyword names--keywords))
+
+(defun names--boundp (sbl)
+ "Is namespace+SBL a boundp symbol?
+If SBL has a let binding, that takes precendence so this also
+returns nil."
+ (and (null (memq sbl names--local-vars))
+ (or (memq sbl names--bound)
+ (and (names--keyword :global)
+ (boundp (names--prepend sbl))))))
+
+;;; This is calling edebug even on `when' and `unless'
+(defun names--args-of-function-or-macro (function args macro)
+ "Namespace FUNCTION's arguments ARGS, with special treatment if MACRO is non-nil."
+ (if macro
+ (let ((it (names--get-edebug-spec function))
+ (names--verbose (eq function 'push)))
+ (names--message "Edebug-spec of `%s' is %s" function it)
+ ;; Macros where we evaluate all arguments are like functions.
+ (if (equal it t)
+ (names--args-of-function-or-macro function args nil)
+ ;; Macros where nothing is evaluated we can just return.
+ (if (equal it 0)
+ (cons function args)
+ ;; Other macros are complicated. Ask edebug for help.
+ (names--macro-args-using-edebug (cons function args)))))
+ ;; We just convert the arguments of functions.
+ (cons function (mapcar 'names-convert-form args))))
+
+(defun names--get-edebug-spec (name)
+ "Get 'edebug-form-spec property of symbol NAME."
+ ;; Get the spec of symbol resolving all indirection.
+ (let ((spec nil)
+ (indirect name))
+ (while (progn
+ (and (symbolp indirect)
+ (setq indirect
+ (names--function-get
+ indirect 'edebug-form-spec 'macro))))
+ ;; (edebug-trace "indirection: %s" edebug-form-spec)
+ (setq spec indirect))
+ spec))
+
+(defvar names--is-inside-macro nil
+ "Auxiliary var used in `names--macro-args-using-edebug'.")
+
+(defvar names--gensym-counter 0
+ "Counter used to uniquify symbols generated `names--gensym'.")
+
+(defun names--macro-args-using-edebug (form)
+ "Namespace the arguments of macro FORM by hacking into edebug.
+This takes advantage of the fact that macros (should) declare a
+`debug' specification which tells us which arguments are actually
+Elisp forms.
+
+Ideally, we would read this specification ourselves and see how
+it matches (cdr FORM), but that would take a lot of work and
+we'd be reimplementing something that edebug already does
+phenomenally. So we hack into edebug instead."
+ (require 'edebug)
+ (require 'cl-lib)
+ (cl-letf
+ ((max-lisp-eval-depth 3000)
+ (edebug-all-forms t)
+ (edebug-all-defs t)
+ (names--is-inside-macro form)
+ ;; Prevent excessive messaging.
+ ;; TODO: Don't do this if `message' is advised.
+ ((symbol-function 'message) #'names--edebug-message)
+ ;; Older edebugs have poor `get-edebug-spec'.
+ ((symbol-function 'get-edebug-spec) #'names--get-edebug-spec)
+ ;; Give symbols our own name.
+ ((symbol-function 'cl-gensym) #'names--gensym)
+ ;; Stop at one level deep.
+ ((symbol-function 'edebug-form) #'names--edebug-form)
+ ;; Don't actually wrap anything.
+ ((symbol-function 'edebug-make-enter-wrapper)
+ #'names--edebug-make-enter-wrapper))
+ (condition-case er
+ (with-temp-buffer
+ (pp form 'insert)
+ (goto-char (point-min))
+ ;; Do the magic!
+ (edebug-read-top-level-form))
+ (invalid-read-syntax
+ (names--warn
+ "Couldn't namespace this macro using its (debug ...) declaration: %s"
+ form)
+ form)
+ (error
+ (when (equal (car-safe (cdr-safe er))
+ "Lisp nesting exceeds `max-lisp-eval-depth'")
+ (names--warn
+ "Lisp nesting exceeded `max-lisp-eval-depth' at the following form: %s"
+ form))
+ form))))
+
+(defvar names--message-backup
+ (if (ad-is-advised 'message)
+ (ad-get-orig-definition 'message)
+ (symbol-function 'message))
+ "Where names stores `message's definition while overriding it.")
+
+(defvar names--verbose nil
+ "If non-nil, verbose message are printed regardless of the :verbose keyword.
+Use this to easily turn on verbosity during tests.")
+
+(defun names--edebug-message (&rest _)
+ (if (or (names--keyword :verbose) names--verbose)
+ (apply names--message-backup _)
+ (when _ (apply 'format _))))
+
+(defun names--edebug-make-enter-wrapper (forms)
+ (setq edebug-def-name
+ (or edebug-def-name
+ edebug-old-def-name
+ (names--gensym "edebug-anon")))
+ (cons 'progn forms))
+
+(defun names--gensym (prefix)
+ "Generate a new uninterned symbol.
+The name is made by appending a number to PREFIX and preppending \"names\", default \"G\"."
+ (let ((num (prog1 names--gensym-counter
+ (setq names--gensym-counter
+ (1+ names--gensym-counter)))))
+ (make-symbol (format "names-%s%d" (if (stringp prefix) prefix "G") num))))
+
+(defun names--edebug-form (cursor)
+ "Parse form given by CURSOR using edebug, and namespace it if necessary."
+ (require 'edebug)
+ ;; Return the instrumented form for the following form.
+ ;; Add the point offsets to the edebug-offset-list for the form.
+ (let* ((form (edebug-top-element-required cursor "Expected form"))
+ (offset (edebug-top-offset cursor))
+ ;; We don't want to convert the entire form that was passed
+ ;; to `names--macro-args-using-edebug', since the head of
+ ;; that was already converted and it would lead to an
+ ;; infinite loop.
+ ;; So we check for (equal names--is-inside-macro form)
+ ;; Simply incrementing a depth counter didn't work, for a
+ ;; reason I can no longer remember.
+
+ ;; We DO want to convert the arguments that edebug identifies
+ ;; as forms (level-1). And we do that ourselves, don't pass
+ ;; them to edebug.
+ (func (if (or (eq names--is-inside-macro t)
+ (equal names--is-inside-macro form))
+ 'identity 'names-convert-form))
+ (names--is-inside-macro
+ (if (eq func 'names-convert-form)
+ t names--is-inside-macro)))
+ (names--message " [Edebug] Ran into this: %S" form)
+ (names--message " Cursor: %S" cursor)
+ (prog1
+ (cond
+ ((consp form) ;; The first offset for a list form is for the list form itself.
+ (if (eq func 'names-convert-form)
+ (names-convert-form form)
+ (let* ((head (car form))
+ (spec (and (symbolp head) (get-edebug-spec head)))
+ (new-cursor (edebug-new-cursor form offset)))
+ ;; Find out if this is a defining form from first symbol.
+ ;; An indirect spec would not work here, yet.
+ (if (and (consp spec) (eq '&define (car spec)))
+ (edebug-defining-form
+ new-cursor
+ (car offset) ;; before the form
+ (edebug-after-offset cursor)
+ (cons (symbol-name head) (cdr spec)))
+ ;; Wrap a regular form.
+ (edebug-list-form new-cursor)))))
+
+ ((symbolp form)
+ (funcall func form))
+
+ ;; Anything else is self-evaluating.
+ (t form))
+ (edebug-move-cursor cursor))))
+
+(defun names--maybe-append-group (form)
+ "Append (:group `names--package') to FORM.
+Only if the :group keyword was passed to `define-namespace' and
+if the form doesn't already have a :group."
+ (if (or (null names--group-parent) (memq :group form))
+ form
+ (append form `(:group ',(names--package-name)))))
+
+\f
+;;; ---------------------------------------------------------------
+;;; Interpreting keywords passed to the main macro.
+(defun names--handle-keyword (body)
+ "Call the function that handles the keyword at the car of BODY.
+Such function must be listed in `names--keyword-list'. If it is
+nil, this function just returns.
+
+Regardless of whether a function was called, the keyword is added
+to the variable `names--keywords'.
+
+The car of BODY is the keyword itself and the other elements are
+the keyword arguments, if any."
+ (let ((func (nth 2 (assoc (car body) names--keyword-list))))
+ (if (functionp func)
+ (apply func (cdr body))
+ nil)))
+
+\f
+;;; ---------------------------------------------------------------
+;;; Interpreting the actual forms found in BODY of the main macro.
+;;
+;; This is where the heavy work is done.
+;;
+;; If you'd like to implement support for some special form, simply
+;; define a function called `names--convert-FORM-NAME' along the
+;; lines of the functions defined below. It will be automatically used
+;; whenever that form is found.
+
+;;; Defun, defmacro, and defsubst macros are pretty predictable.
+(defun names--convert-defmacro (form)
+ "Special treatment for `defmacro' FORM."
+ (let* ((names--name-already-prefixed t)
+ (name (cadr form))
+ (spaced-name (names--prepend name))
+ decl)
+ (add-to-list 'names--macro name)
+ (add-to-list 'names--fbound name)
+ ;; Set the macros debug spec if possible. It will be relevant on
+ ;; the next run.
+ (when (setq decl (ignore-errors (cond
+ ((eq (car-safe (nth 3 form)) 'declare)
+ (nth 3 form))
+ ((and (stringp (nth 3 form))
+ (eq (car-safe (nth 4 form)) 'declare))
+ (nth 4 form))
+ (t nil))))
+ (setq decl (car (cdr-safe (assoc 'debug (cdr decl)))))
+ (when decl (put spaced-name 'edebug-form-spec decl)))
+ ;; Then convert the macro as a defalias.
+ (cons
+ (car form)
+ (names--convert-lambda
+ (cons spaced-name (cddr form))))))
+(defalias 'names--convert-defmacro* 'names--convert-defmacro)
+
+(defun names--convert-defvaralias (form)
+ "Special treatment for `defvaralias' FORM."
+ (let ((form (cons (car form)
+ (mapcar #'names-convert-form (cdr form))))
+ (name))
+ (setq name (names--remove-namespace
+ (ignore-errors (eval (cadr form)))))
+ (when name
+ (add-to-list 'names--bound name))
+ form))
+
+(defun names--convert-defalias (form)
+ "Special treatment for `defalias' FORM."
+ (let ((form (cons (car form)
+ (mapcar #'names-convert-form (cdr form))))
+ (name))
+ (setq name (names--remove-namespace
+ (ignore-errors (eval (cadr form)))))
+ (when name
+ (add-to-list 'names--fbound name))
+ form))
+
+(defun names--convert-defvar (form &optional dont-add)
+ "Special treatment for `defvar' FORM.
+If DONT-ADD is nil, the FORM's `cadr' is added to `names--bound'."
+ (let ((name (cadr form)))
+ (unless dont-add
+ (add-to-list 'names--bound name))
+ (append
+ (list
+ (car form)
+ (names--prepend name))
+ (mapcar 'names-convert-form (cdr (cdr form))))))
+
+(defalias 'names--convert-defconst 'names--convert-defvar
+ "Special treatment for `defconst' FORM.")
+
+(defun names--convert-defcustom (form)
+ "Special treatment for `defcustom' FORM."
+ (names--maybe-append-group
+ (names--convert-defvar form)))
+
+(defun names--convert-custom-declare-variable (form)
+ "Special treatment for `custom-declare-variable' FORM."
+ (let ((name (eval (cadr form))) ;;ignore-errors
+ (val (car (cddr form))))
+ (add-to-list 'names--bound name)
+ (append
+ (list
+ (car form)
+ (list 'quote (names--prepend name)) ;cadr
+ ;; The DEFAULT argument is explicitly evaluated by
+ ;; `custom-declare-variable', so it should be safe to namespace
+ ;; even when quoted. Plus, we need to do this because
+ ;; defcustom quotes this part.
+ (if (names--quote-p (car-safe val))
+ (list (car val) (names-convert-form (cadr val)))
+ (names-convert-form val))
+ (names-convert-form (car (cdr (cdr (cdr form))))))
+ (mapcar 'names-convert-form (cdr (cdr (cdr (cdr form))))))))
+
+(defun names--convert-defface (form)
+ "Special treatment for `defface' FORM.
+Identical to defvar, just doesn't add the symbol to the boundp
+list. And maybe use a :group."
+ (names--maybe-append-group
+ (names--convert-defvar form :dont-add)))
+
+(defun names--convert-define-derived-mode (form)
+ "Special treatment for `define-derived-mode' FORM."
+ (let ((name (cadr form)))
+ (add-to-list 'names--fbound name)
+ (add-to-list 'names--bound name)
+ (add-to-list 'names--bound
+ (intern (format "%s-map" name)))
+ (add-to-list 'names--bound
+ (intern (format "%s-hook" name)))
+ (append
+ (names--maybe-append-group
+ ;; And here we namespace it.
+ (list
+ (car form)
+ (names--prepend name)
+ (nth 2 form)
+ (names-convert-form (nth 3 form))
+ (names-convert-form (nth 4 form))))
+ (mapcar #'names-convert-form (cddr form)))))
+
+(defun names--convert-define-minor-mode (form)
+ "Special treatment for `define-minor-mode' FORM."
+ (let ((name (cadr form))
+ (keymap (nth 5 form)))
+ ;; Register the mode name
+ (add-to-list 'names--fbound name)
+ (add-to-list 'names--bound name)
+ (add-to-list 'names--bound (intern (format "%s-hook" name)))
+ ;; Register the keymap
+ (if (or (null keymap) (null (symbolp keymap)))
+ (add-to-list 'names--bound (intern (format "%s-map" name)))
+ (when (setq keymap (names--remove-namespace keymap))
+ (add-to-list 'names--bound keymap)))
+ (append
+ (names--maybe-append-group
+ ;; And here we namespace it.
+ (list
+ (car form)
+ (names--prepend name)
+ (nth 2 form)
+ (names-convert-form (nth 3 form))
+ (names-convert-form (nth 4 form))
+ (names-convert-form (nth 5 form))
+ (names-convert-form (nth 6 form))))
+ (mapcar #'names-convert-form (cddr form)))))
+
+(defun names--convert-define-globalized-minor-mode (form)
+ "Special treatment for `define-globalized-minor-mode' FORM.
+The NAME of the global mode will NOT be namespaced, despite being
+a definition. It is kept verbatim.
+This is because people tend to name their global modes as
+`global-foo-mode', and namespacing would make this impossible.
+
+The MODE and TURN-ON arguments are converted as function names.
+Everything else is converted as regular forms (which usually
+means no conversion will happen since it's usually keywords and
+quoted symbols)."
+ (let ((name (names--remove-namespace (cadr form)))
+ (copy (cl-copy-list form)))
+ ;; Register the mode name
+ (when name
+ (add-to-list 'names--fbound name)
+ (add-to-list 'names--bound name)
+ (add-to-list 'names--bound (intern (format "%s-hook" name))))
+ (names--maybe-append-group
+ ;; And here we namespace it.
+ (append
+ (list
+ (pop copy)
+ (pop copy)
+ (names--handle-symbol-as-function (pop copy))
+ (names--handle-symbol-as-function (pop copy)))
+ (mapcar #'names-convert-form copy)))))
+(defalias #'names--convert-define-global-minor-mode
+ #'names--convert-define-globalized-minor-mode)
+(defalias #'names--convert-easy-mmode-define-global-mode
+ #'names--convert-define-globalized-minor-mode)
+
+(defun names--convert-quote (form)
+ "Special treatment for `quote' FORM.
+When FORM is (quote argument), argument too arbitrary to be
+logically namespaced and is never parsed for namespacing
+ (but see :assume-var-quote in `names--keyword-list').
+
+When FORM is (function form), a symbol is namespaced as a
+function name, a list is namespaced as a lambda form."
+ (let ((kadr (cadr form))
+ (this-name (car form))
+ func)
+ (if (and (eq this-name 'function)
+ (listp kadr))
+ (list this-name (names-convert-form kadr))
+ (if (symbolp kadr)
+ (cond
+ ;; A symbol inside a function quote should be a function,
+ ;; unless the user disabled that.
+ ((and (eq this-name 'function)
+ (null (names--keyword :dont-assume-function-quote)))
+ (list 'function
+ (names--handle-symbol-as-function kadr)))
+
+ ;; A symbol inside a regular quote should be a function, if
+ ;; the user asked for that.
+ ((and (eq this-name 'quote)
+ (names--keyword :assume-var-quote))
+ (list 'quote
+ (or (names--remove-protection kadr)
+ (if (names--boundp kadr)
+ (names--prepend kadr)
+ kadr))))
+
+ (t form))
+ form))))
+
+(defun names--handle-symbol-as-function (s)
+ "Namespace symbol S as a function name."
+ (or (names--remove-protection s)
+ (if (names--fboundp s) (names--prepend s) s)))
+
+(defalias 'names--convert-function 'names--convert-quote)
+
+(defun names--convert-macro (form)
+ "Special treatment for `macro' form.
+Return (macro . (names-convert-form (cdr FORM)))."
+ (cons 'macro (names-convert-form (cdr form))))
+
+(defun names--convert-lambda (form)
+ "Special treatment for `lambda' FORM."
+ (let ((names--local-vars
+ (append (names--vars-from-arglist (cadr form))
+ names--local-vars))
+ (forms (cdr (cdr form))))
+ (append
+ (list (car form)
+ (cadr form))
+ (when (stringp (car forms))
+ (prog1
+ (list (car forms))
+ (setq forms (cdr forms))))
+ (when (eq 'interactive (car-safe (car forms)))
+ (prog1
+ (list (list (car (car forms))
+ (names-convert-form (cadr (car forms)))))
+ (setq forms (cdr forms))))
+ (progn
+ ;; (message "%S" forms)
+ (mapcar 'names-convert-form forms)))))
+
+(defun names--convert-clojure (form)
+ "Special treatment for `clojure' FORM."
+ (names--warn "Found a `closure'! You should use `lambda's instead")
+ (let ((names--local-vars
+ (append (names--vars-from-arglist (cadr form))
+ names--local-vars))
+ (forms (cdr (cdr form))))
+ (cons
+ (car form)
+ (names--convert-lambda (cdr form)))))
+
+(defun names--vars-from-arglist (args)
+ "Get a list of local variables from a generalized arglist ARGS."
+ (remove
+ nil
+ (mapcar
+ (lambda (x)
+ (let ((symb (or (cdr-safe (car-safe x)) (car-safe x) x)))
+ (when (and (symbolp symb)
+ (null (string-match "^&" (symbol-name symb)))
+ (null (eq symb t)))
+ symb)))
+ args)))
+
+(defun names--convert-defun (form)
+ "Special treatment for `defun' FORM."
+ (let* ((name (cadr form)))
+ (add-to-list 'names--fbound name)
+ (cons (car form)
+ (names--convert-lambda
+ (cons (names--prepend name) (cddr form))))))
+(defalias 'names--convert-defun* 'names--convert-defun)
+(defalias 'names--convert-defsubst 'names--convert-defun)
+(defalias 'names--convert-defsubst* 'names--convert-defun)
+
+(defun names--let-var-convert-then-add (sym add)
+ "Try to convert SYM unless :no-let-vars is in use.
+If ADD is non-nil, add resulting symbol to `names--local-vars'."
+ (let ((name (if (null (names--keyword :no-let-vars))
+ (names-convert-form sym)
+ sym)))
+ (when add (add-to-list 'names--local-vars name))
+ name))
+
+(defun names--convert-let (form &optional star)
+ "Special treatment for `let' FORM.
+If STAR is non-nil, parse as a `let*'."
+ (let* ((names--local-vars names--local-vars)
+ (vars
+ (mapcar
+ (lambda (x)
+ (if (car-safe x)
+ (list (names--let-var-convert-then-add (car x) star)
+ (names-convert-form (cadr x)))
+ (names--let-var-convert-then-add x star)))
+ (cadr form))))
+ ;; Each var defined in a regular `let' only becomes protected after
+ ;; all others have been defined.
+ (unless star
+ (setq names--local-vars
+ (append
+ (mapcar (lambda (x) (or (car-safe x) x)) vars)
+ names--local-vars)))
+ (append
+ (list (car form) vars)
+ (mapcar 'names-convert-form (cddr form)))))
+
+(defun names--convert-let* (form)
+ "Special treatment for `let' FORM."
+ (names--convert-let form t))
+
+(defun names--convert-cond (form)
+ "Special treatment for `cond' FORM."
+ (cons
+ (car form)
+ (mapcar
+ (lambda (x) (mapcar #'names-convert-form x))
+ (cdr form))))
+
+(defun names--convert-condition-case (form)
+ "Special treatment for `condition-case' FORM."
+ (append
+ (list
+ (car form)
+ (cadr form)
+ (names-convert-form (cadr (cdr form))))
+ (mapcar
+ (lambda (x)
+ (cons (car x)
+ (mapcar 'names-convert-form (cdr x))))
+ (cddr (cdr form)))))
+
+(provide 'names)
+;;; names.el ends here