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