emacs/nxhtml/util/rxi.el

   1 ;;; rxi.el --- Interactive regexp reading using rx format
   2 ;;
   3 ;; Author: Lennart Borgman (lennart O borgman A gmail O com)
   4 ;; Created: 2008-04-07T18:18:39+0200 Mon
   5 ;; Version:
   6 ;; Last-Updated:
   7 ;; URL:
   8 ;; Keywords:
   9 ;; Compatibility:
  10 ;;
  11 ;; Features that might be required by this library:
  12 ;;
  13 ;;   None
  14 ;;
  15 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  16 ;;
  17 ;;; Commentary:
  18 ;;
  19 ;; Read regexp as `rx' forms from minibuffer.
  20 ;;
  21 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  22 ;;
  23 ;;; Change log:
  24 ;;
  25 ;;
  26 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  27 ;;
  28 ;; This program is free software; you can redistribute it and/or
  29 ;; modify it under the terms of the GNU General Public License as
  30 ;; published by the Free Software Foundation; either version 2, or
  31 ;; (at your option) any later version.
  32 ;;
  33 ;; This program is distributed in the hope that it will be useful,
  34 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  35 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  36 ;; General Public License for more details.
  37 ;;
  38 ;; You should have received a copy of the GNU General Public License
  39 ;; along with this program; see the file COPYING.  If not, write to
  40 ;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth
  41 ;; Floor, Boston, MA 02110-1301, USA.
  42 ;;
  43 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  44 ;;
  45 ;;; Code:
  46
  47 (defvar rxi-read-hist nil)
  48
  49 (defun rxi-find-definition (rx-sym)
  50   (let* ((rec (assoc rx-sym rx-constituents))
  51          )
  52     (while (symbolp (cdr rec))
  53       (setq rec (assoc (cdr rec) rx-constituents)))
  54     (cdr rec)))
  55
  56 (defun rxi-list-type-p (rx-sym)
  57   (listp (rxi-find-definition rx-sym)))
  58
  59 (defun rxi-complete ()
  60   "Complete `rx' constituents."
  61   (interactive)
  62   ;; Don't care about state for now, there will be an error instead
  63   (let* ((partial (when (looking-back (rx (1+ (any "a-z01:|=>*?+\\-"))) nil t)
  64                     (match-string-no-properties 0)))
  65          (candidates (let ((want-list
  66                             (= ?\( (char-before (match-beginning 0)))))
  67                        (delq nil
  68                              (mapcar (lambda (rec)
  69                                        (let* ((sym (car rec))
  70                                               (lst (rxi-list-type-p sym)))
  71                                          (when (or (and want-list lst)
  72                                                    (and (not want-list)
  73                                                         (not lst)))
  74                                            (symbol-name sym))))
  75                                      rx-constituents))))
  76          (match-set (when partial
  77                       (all-completions
  78                        partial
  79                        candidates))))
  80     (cond
  81      ((not match-set)
  82       (message "No completions"))
  83      ((= 1 (length match-set))
  84       (insert (substring (car match-set) (length partial))))
  85      (t
  86       (with-output-to-temp-buffer "*Completions*"
  87           (display-completion-list match-set partial))))))
  88
  89 (defvar rxi-read-keymap
  90   (let ((map (make-sparse-keymap)))
  91     (set-keymap-parent map minibuffer-local-completion-map)
  92     (define-key map [tab] 'rxi-complete)
  93     (define-key map [(meta tab)] 'rxi-complete)
  94     (define-key map [?\ ] 'self-insert-command)
  95     map))
  96
  97 (defvar rxi-trailing-overlay nil)
  98
  99 (defun rxi-minibuf-setup ()
 100   (when rxi-trailing-overlay (delete-overlay rxi-trailing-overlay))
 101   (setq rxi-trailing-overlay
 102         (make-overlay (point-max) (point-max)
 103                       (current-buffer)
 104                       t t))
 105   (overlay-put rxi-trailing-overlay 'after-string
 106                (propertize ")"
 107                            'face
 108                            (if (and
 109                                 (fboundp 'noticeable-minibuffer-prompts-mode)
 110                                 noticeable-minibuffer-prompts-mode)
 111                                'minibuffer-noticeable-prompt
 112                              'minibuffer-prompt)))
 113   (remove-hook 'minibuffer-setup-hook 'rxi-minibuf-setup))
 114
 115 (defun rxi-minibuf-exit ()
 116   (when rxi-trailing-overlay
 117     (delete-overlay rxi-trailing-overlay)
 118     (setq rxi-trailing-overlay nil))
 119   (remove-hook 'minibuffer-exit-hook 'rxi-minibuf-exit))
 120
 121 (defun rxi-read (prompt)
 122   "Read a `rx' regexp form from minibuffer.
 123 Return cons of rx and regexp, both as strings."
 124   (interactive (list "Test (rx "))
 125   (let (rx-str rx-full-str res-regexp)
 126     (while (not res-regexp)
 127       (condition-case err
 128           (progn
 129             (add-hook 'minibuffer-setup-hook 'rxi-minibuf-setup)
 130             (add-hook 'minibuffer-exit-hook 'rxi-minibuf-exit)
 131             (setq rx-str (read-from-minibuffer prompt
 132                                                rx-str ;; initial-contents
 133                                                rxi-read-keymap
 134                                                nil ;; read
 135                                                'rxi-read-hist
 136                                                nil ;; inherit-input-method - no idea...
 137                                                ))
 138             (setq rx-full-str (concat "(rx " rx-str ")"))
 139             (setq res-regexp (eval (read rx-full-str))))
 140         (error (message "%s" (error-message-string err))
 141                (sit-for 2))))
 142     (when (with-no-warnings (called-interactively-p)) (message "%s => \"%s\"" rx-full-str res-regexp))
 143     (cons rx-full-str res-regexp)))
 144
 145
 146 (provide 'rxi)
 147 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 148 ;;; rxi.el ends here