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

   1 ;;; nameless.el --- Hide package namespace in your emacs-lisp code  -*- lexical-binding: t; -*-
   2
   3 ;; Copyright (C) 2015 Free Software Foundation, Inc.
   4
   5 ;; Author: Artur Malabarba <emacs@endlessparentheses.com>
   6 ;; URL: https://github.com/Malabarba/nameless
   7 ;; Keywords: convenience, lisp
   8 ;; Version: 0.5.1
   9 ;; Package-Requires: ((emacs "24.4"))
  10
  11 ;; This program is free software; you can redistribute it and/or modify
  12 ;; it under the terms of the GNU General Public License as published by
  13 ;; the Free Software Foundation, either version 3 of the License, or
  14 ;; (at your option) any later version.
  15
  16 ;; This program is distributed in the hope that it will be useful,
  17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 ;; GNU General Public License for more details.
  20
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
  23
  24 ;;; Commentary:
  25
  26 ;; Usage
  27 ;; ─────
  28 ;;
  29 ;;   To use this package add the following configuration to your Emacs init
  30 ;;   file.
  31 ;;
  32 ;;   ┌────
  33 ;;   │ (add-hook 'emacs-lisp-mode-hook #'nameless-mode)
  34 ;;   └────
  35 ;;
  36 ;;   You can configure a string to use instead of `:' by setting the
  37 ;;   `nameless-prefix', and the name of the face used is `nameless-face'.
  38 ;;
  39 ;;   While the mode is active, the `_' key inserts the package
  40 ;;   namespace if appropriate.
  41
  42 ;;; Code:
  43 (require 'lisp-mnt)
  44
  45 (defgroup nameless nil
  46   "Customization group for nameless."
  47   :group 'emacs)
  48
  49 (defcustom nameless-prefix ":"
  50   "Prefix displayed instead of package namespace."
  51   :type 'string)
  52
  53 (defcustom nameless-global-aliases '(("fl" . "font-lock"))
  54   "Alist from aliases to namespaces.
  55 This alist is used everywhere.  It is designed for namespaces you
  56 use commonly.  To apply aliases specific to a file, set the
  57 `nameless-aliases' variable with `add-file-local-variable'.
  58
  59 Each element of this list should have the form (ALIAS . NAMESPACE),
  60 both strings.  For example, if you set this variable to
  61           ((\"fl\" . \"font-lock\"))
  62 then expressions like `(font-lock-add-keywords nil kwds)' will
  63 displayed as `(fl/add-keywords nil kwds)' instead.
  64
  65 Furthermore typing `fl' followed by `\\[nameless-insert-name]' will
  66 automatically insert `font-lock-'."
  67   :type '(alist string string))
  68
  69 (defvar nameless-aliases nil
  70   "Alist from aliases to namespaces.
  71 This variable takes the same syntax and has the same effect as
  72 `nameless-global-aliases'.  Aliases set here take priority over
  73 those in `nameless-global-aliases'.
  74 This variable is designed to be used as a file-local or dir-local
  75 variable.")
  76 (put 'nameless-aliases 'safe-local-variable
  77      (lambda (x) (ignore-errors
  78               (let ((safe t))
  79                 (mapc (lambda (cell)
  80                         (unless (and (stringp (car cell))
  81                                      (stringp (cdr cell)))
  82                           (setq safe nil)))
  83                       x)
  84                 safe))))
  85
  86 (defcustom nameless-discover-current-name t
  87   "If non-nil, discover package name automatically.
  88 If nil, `nameless-current-name' must be set explicitly, or left as nil,
  89 in which case only namespaces from `nameless-global-aliases' and
  90 `nameless-aliases' are used."
  91   :type 'boolean)
  92
  93 (defface nameless-face
  94   '((t :inherit font-lock-type-face))
  95   "Face used on `nameless-prefix'")
  96
  97 (defcustom nameless-affect-indentation-and-filling 'outside-strings
  98   "If non-nil, code is indented and filled according to what you see.
  99 If nil, code is indented and filled according to its actual content.
 100 If the value is `outside-strings', behave like nil inside strings
 101 and behave like t otherwise.
 102
 103 After changing this variable, you must reenable `nameless-mode'
 104 for it to take effect."
 105   :type '(choice (const :tag "Always affect indentation" t)
 106                  (const :tag "Don't affect indentation" nil)
 107                  (const :tag "Only outside strings" outside-strings)))
 108 (put 'nameless-current-name 'safe-local-variable #'symbolp)
 109
 110 (defcustom nameless-private-prefix nil
 111   "If non-nil, private symbols are displayed with a double prefix.
 112 For instance, the function `foobar--internal-impl' will be
 113 displayed as `::internal-impl', instead of `:-internal-impl'."
 114   :type 'boolean)
 115
 116 (defcustom nameless-separator "-"
 117   "Separator used between package prefix and rest of symbol.
 118 The separator is hidden along with the package name.  For
 119 instance, setting it to \"/\" means that `init/bio' will be
 120 displayed as `:bio' (assuming `nameless-current-name' is
 121 \"init\").  The default is \"-\", since this is the
 122 separator recommended by the Elisp manual.
 123
 124 Value can also be nil, in which case the separator is never hidden."
 125   :type '(choice string (constant nil)))
 126
 127 \f
 128 ;;; Font-locking
 129 (defun nameless--make-composition (s)
 130   "Return a list that composes S if passed to `compose-region'."
 131   (cdr (apply #'append (mapcar (lambda (x) (list '(Br . Bl) x)) s))))
 132
 133 (defvar nameless-mode)
 134 (defun nameless--compose-as (display)
 135   "Compose the matched region and return a face spec."
 136   (when (and nameless-mode
 137              (not (get-text-property (match-beginning 1) 'composition))
 138              (not (get-text-property (match-beginning 1) 'display)))
 139     (let ((compose (save-match-data
 140                      (and nameless-affect-indentation-and-filling
 141                           (or (not (eq nameless-affect-indentation-and-filling 'outside-strings))
 142                               (not (nth 3 (syntax-ppss)))))))
 143           (dis (concat display nameless-prefix))
 144           (beg (match-beginning 1))
 145           (end (match-end 1))
 146           (private-prefix (and nameless-private-prefix
 147                                (equal nameless-separator (substring (match-string 0) -1)))))
 148       (when private-prefix
 149         (setq beg (match-beginning 0))
 150         (setq end (match-end 0))
 151         (setq dis (concat dis nameless-prefix)))
 152       (if compose
 153           (compose-region beg end (nameless--make-composition dis))
 154         (add-text-properties beg end (list 'display dis)))
 155       '(face nameless-face))))
 156
 157 (defvar-local nameless--font-lock-keywords nil)
 158
 159 (defun nameless--ensure ()
 160   (save-excursion
 161     (font-lock-fontify-region (point-min) (point-max))))
 162
 163 (defun nameless--remove-keywords ()
 164   "Remove font-lock keywords set by `nameless--add-keywords'."
 165   (font-lock-remove-keywords nil nameless--font-lock-keywords)
 166   (setq nameless--font-lock-keywords nil)
 167   (nameless--ensure))
 168
 169 (defun nameless--add-keywords (&rest r)
 170   "Add font-lock keywords displaying ALIAS as DISPLAY.
 171 ALIAS may be nil, in which case it refers to `nameless-current-name'.
 172
 173 \(fn (alias . display) [(alias . display) ...])"
 174   (setq-local font-lock-extra-managed-props
 175               `(composition display ,@font-lock-extra-managed-props))
 176   (let ((kws (mapcar (lambda (x) `(,(nameless--name-regexp (cdr x)) 1 (nameless--compose-as ,(car x)) prepend)) r)))
 177     (setq nameless--font-lock-keywords kws)
 178     (font-lock-add-keywords nil kws t))
 179   (nameless--ensure))
 180
 181 \f
 182 ;;; Name and regexp
 183 (defvar-local nameless-current-name nil)
 184 (put 'nameless-current-name 'safe-local-variable #'stringp)
 185
 186 (defun nameless--in-arglist-p (l)
 187   "Is point L inside an arglist?"
 188   (save-excursion
 189     (goto-char l)
 190     (ignore-errors
 191       (backward-up-list)
 192       (or (progn (forward-sexp -1)
 193                  (looking-at-p "[a-z-]lambda\\_>"))
 194           (progn (forward-sexp -1)
 195                  (looking-at-p "\\(cl-\\)?def"))))))
 196
 197 (defun nameless-insert-name (&optional noerror)
 198   "Insert `nameless-current-name' or the alias at point.
 199 If point is immediately after an alias configured in
 200 `nameless-aliases' or `nameless-global-aliases', replace it with
 201 the full name for that alias.
 202 Otherwise, insert `nameless-current-name'.
 203
 204 If NOERROR is nil, signal an error if the alias at point is not
 205 configured, or if `nameless-current-name' is nil."
 206   (interactive)
 207   (if (string-match (rx (or (syntax symbol)
 208                             (syntax word)))
 209                     (string (char-before)))
 210       (let* ((r (point))
 211              (l (save-excursion
 212                   (forward-sexp -1)
 213                   (skip-chars-forward "^[:alnum:]")
 214                   (point)))
 215              (alias (buffer-substring l r))
 216              (full-name (when alias
 217                           (cdr (or (assoc alias nameless-aliases)
 218                                    (assoc alias nameless-global-aliases))))))
 219         (if full-name
 220             (progn (delete-region l r)
 221                    (insert full-name "-")
 222                    t)
 223           (unless noerror
 224             (user-error "No name for alias `%s', see `nameless-aliases'" alias))))
 225     (if nameless-current-name
 226         (progn (insert nameless-current-name nameless-separator)
 227                t)
 228       (unless noerror
 229         (user-error "No name for current buffer, see `nameless-current-name'")))))
 230
 231 (defun nameless-insert-name-or-self-insert (&optional self-insert)
 232   "Insert the name of current package, with a hyphen."
 233   (interactive "P")
 234   (let ((l (point)))
 235     (call-interactively #'self-insert-command)
 236     (unless (or self-insert
 237                 (not nameless-current-name)
 238                 (eq (char-before l) ?\\)
 239                 (nameless--in-arglist-p l))
 240       (undo-boundary)
 241       (delete-region l (point))
 242       (unless (nameless-insert-name 'noerror)
 243         (call-interactively #'self-insert-command)))))
 244
 245 (put 'nameless-insert-name-or-self-insert 'delete-selection t)
 246
 247 (defun nameless--name-regexp (name)
 248   "Return a regexp of the current name."
 249   (concat "\\_<@?\\(" (regexp-quote name)
 250           nameless-separator "\\)\\(\\s_\\|\\sw\\)"))
 251
 252 (defun nameless--filter-string (s)
 253   "Remove from string S any disply or composition properties.
 254 Return S."
 255   (let ((length (length s)))
 256     (remove-text-properties 0 length '(composition nil display nil) s)
 257     s))
 258
 259 \f
 260 ;;; Minor mode
 261 ;;;###autoload
 262 (define-minor-mode nameless-mode
 263   nil nil " :" `((,(kbd "C-c C--") . nameless-insert-name))
 264   (if nameless-mode
 265       (progn
 266         (when (and (not nameless-current-name)
 267                    nameless-discover-current-name
 268                    (ignore-errors (string-match "\\.el\\'" (lm-get-package-name))))
 269           (setq nameless-current-name
 270                 (replace-regexp-in-string "\\(-mode\\)?\\.[^.]*\\'" "" (lm-get-package-name))))
 271         (add-function :filter-return (local 'filter-buffer-substring-function)
 272                       #'nameless--filter-string)
 273         (apply #'nameless--add-keywords
 274                `(,@(when nameless-current-name
 275                      `((nil . ,nameless-current-name)))
 276                  ,@nameless-global-aliases
 277                  ,@nameless-aliases)))
 278     (remove-function (local 'filter-buffer-substring-function)
 279                      #'nameless--filter-string)
 280     (setq nameless-current-name nil)
 281     (nameless--remove-keywords)))
 282
 283 ;;;###autoload
 284 (defun nameless-mode-from-hook ()
 285   "Turn on `nameless-mode'.
 286 Designed to be added to `emacs-lisp-mode-hook'.
 287 Interactively, just invoke `nameless-mode' directly."
 288   (add-hook 'find-file-hook #'nameless-mode nil 'local))
 289
 290 (provide 'nameless)
 291 ;;; nameless.el ends here