code.delx.au - gnu-emacs-elpa/blob - 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.3.1
   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
  76 (defface nameless-face
  77   '((t :inherit font-lock-type-face))
  78   "Face used on `nameless-prefix'")
  79
  80 (defcustom nameless-affect-indentation-and-filling 'outside-strings
  81   "If non-nil, code is indented and filled according to what you see.
  82 If nil, code is indented and filled according to its actual content.
  83 If the value is `outside-strings', behave like nil inside strings
  84 and behave like t otherwise.
  85
  86 After changing this variable, you must reenable `nameless-mode'
  87 for it to take effect."
  88   :type '(choice (const :tag "Always affect indentation" t)
  89                  (const :tag "Don't affect indentation" nil)
  90                  (const :tag "Only outside strings" 'outside-strings)))
  91
  92 \f
  93 ;;; Font-locking
  94 (defun nameless--make-composition (s)
  95   "Return a list that composes S if passed to `compose-region'."
  96   (cdr (apply #'append (mapcar (lambda (x) (list '(Br . Bl) x)) s))))
  97
  98 (defvar nameless-mode)
  99 (defun nameless--compose-as (display)
 100   "Compose the matched region and return a face spec."
 101   (when (and nameless-mode
 102              (not (get-text-property (match-beginning 1) 'composition))
 103              (not (get-text-property (match-beginning 1) 'display)))
 104     (let ((compose (save-match-data
 105                      (and nameless-affect-indentation-and-filling
 106                           (or (not (eq nameless-affect-indentation-and-filling 'outside-strings))
 107                               (not (nth 3 (syntax-ppss)))))))
 108           (dis (concat display nameless-prefix)))
 109       (when compose
 110         (compose-region (match-beginning 1)
 111                         (match-end 1)
 112                         (nameless--make-composition dis)))
 113       `(face nameless-face ,@(unless compose (list 'display dis))))))
 114
 115 (defvar-local nameless--font-lock-keywords nil)
 116
 117 (defun nameless--ensure ()
 118   (save-excursion
 119     (font-lock-fontify-region (point-min) (point-max))))
 120
 121 (defun nameless--remove-keywords ()
 122   "Remove font-lock keywords set by `nameless--add-keywords'."
 123   (font-lock-remove-keywords nil nameless--font-lock-keywords)
 124   (setq nameless--font-lock-keywords nil)
 125   (nameless--ensure))
 126
 127 (defun nameless--add-keywords (&rest r)
 128   "Add font-lock keywords displaying REGEXP as DISPLAY.
 129
 130 \(fn (regexp . display) [(regexp . display) ...])"
 131   (setq-local font-lock-extra-managed-props
 132               `(composition display ,@font-lock-extra-managed-props))
 133   (let ((kws (mapcar (lambda (x) `(,(nameless--name-regexp (cdr x)) 1 (nameless--compose-as ,(car x)))) r)))
 134     (setq nameless--font-lock-keywords kws)
 135     (font-lock-add-keywords nil kws t))
 136   (nameless--ensure))
 137
 138 \f
 139 ;;; Name and regexp
 140 (defvar-local nameless-current-name nil)
 141
 142 (defun nameless--in-arglist-p ()
 143   "Is point inside an arglist?"
 144   (save-excursion
 145     (ignore-errors
 146       (backward-up-list)
 147       (or (progn (forward-sexp -1)
 148                  (looking-at-p "[a-z-]lambda\\_>"))
 149           (progn (forward-sexp -1)
 150                  (looking-at-p "\\(cl-\\)?def\\(un\\|macro\\|inline\\)\\*?\\_>"))))))
 151
 152 (defun nameless-insert-name (&optional noerror)
 153   "Insert `nameless-current-name' or the alias at point.
 154 If point is immediately after an alias configured in
 155 `nameless-aliases' or `nameless-global-aliases', replace it with
 156 the full name for that alias.
 157 Otherwise, insert `nameless-current-name'.
 158
 159 If NOERROR is nil, signal an error if the alias at point is not
 160 configured, or if `nameless-current-name' is nil."
 161   (interactive)
 162   (if (string-match (rx (or (syntax symbol)
 163                             (syntax word)))
 164                     (string (char-before)))
 165       (let* ((r (point))
 166              (l (save-excursion
 167                   (forward-sexp -1)
 168                   (skip-chars-forward "^[:alnum:]")
 169                   (point)))
 170              (alias (buffer-substring l r))
 171              (full-name (when alias
 172                           (cdr (or (assoc alias nameless-aliases)
 173                                    (assoc alias nameless-global-aliases))))))
 174         (if full-name
 175             (progn (delete-region l r)
 176                    (insert full-name "-")
 177                    t)
 178           (unless noerror
 179             (user-error "No name for alias `%s', see `nameless-aliases'" alias))))
 180     (if nameless-current-name
 181         (progn (insert nameless-current-name "-")
 182                t)
 183       (unless noerror
 184         (user-error "No name for current buffer, see `nameless-current-name'")))))
 185
 186 (defun nameless-insert-name-or-self-insert (&optional self-insert)
 187   "Insert the name of current package, with a hyphen."
 188   (interactive "P")
 189   (if (or self-insert
 190           (not nameless-current-name)
 191           (eq (char-before) ?\\)
 192           (nameless--in-arglist-p))
 193       (call-interactively #'self-insert-command)
 194     (or (nameless-insert-name 'noerror)
 195         (call-interactively #'self-insert-command))))
 196
 197 (put 'nameless-insert-name-or-self-insert 'delete-selection t)
 198
 199 (defun nameless--name-regexp (name)
 200   "Return a regexp of the current name."
 201   (concat "\\_<@?\\(" (regexp-quote name) "-\\)\\(\\s_\\|\\sw\\)"))
 202
 203 (defun nameless--filter-string (s)
 204   "Remove from string S any disply or composition properties.
 205 Return S."
 206   (let ((length (length s)))
 207     (remove-text-properties 0 length '(composition nil display nil) s)
 208     s))
 209
 210 \f
 211 ;;; Minor mode
 212 ;;;###autoload
 213 (define-minor-mode nameless-mode
 214   nil nil " :" `((,(kbd "C-c C--") . nameless-insert-name))
 215   (if nameless-mode
 216       (if (or nameless-current-name
 217               (ignore-errors (string-match "\\.el\\'" (lm-get-package-name))))
 218           (progn
 219             (unless nameless-current-name
 220               (setq nameless-current-name (replace-regexp-in-string "\\.[^.]*\\'" "" (lm-get-package-name))))
 221             (add-function :filter-return (local 'filter-buffer-substring-function)
 222                           #'nameless--filter-string)
 223             (apply #'nameless--add-keywords
 224                    `((nil . ,nameless-current-name)
 225                      ,@nameless-global-aliases
 226                      ,@nameless-aliases)))
 227         (nameless-mode -1))
 228     (remove-function (local 'filter-buffer-substring-function)
 229                      #'nameless--filter-string)
 230     (setq nameless-current-name nil)
 231     (nameless--remove-keywords)))
 232
 233 (provide 'nameless)
 234 ;;; nameless.el ends here