cgit.sxemacs.org Git - packages/blob - xemacs-packages/liece/lisp/liece-minibuf.el

   1 ;;; liece-minibuf.el --- Minibuffer custom completion.
   2 ;; Copyright (C) 1998-2000 Daiki Ueno
   3
   4 ;; Author: Daiki Ueno <ueno@unixuser.org>
   5 ;; Created: 1999-02-02
   6 ;; Revised: 1999-02-02
   7 ;; Keywords: minibuffer, completion
   8
   9 ;; This file is part of Liece.
  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 2, or (at your option)
  14 ;; 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 GNU Emacs; see the file COPYING.  If not, write to the
  23 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  24 ;; Boston, MA 02111-1307, USA.
  25
  26
  27 ;;; Commentary:
  28 ;;
  29
  30 ;;; Code:
  31
  32 (require 'liece-compat)
  33 (require 'liece-intl)
  34 (require 'liece-nick)
  35 (eval-when-compile
  36   (require 'liece-channel)
  37   (require 'liece-inlines))
  38
  39 (defvar liece-minibuffer-map nil)
  40 (defvar liece-minibuffer-complete-function nil)
  41
  42 (autoload 'completing-read-multiple "crm")
  43 (defvar crm-separator)
  44
  45 (unless liece-minibuffer-map
  46   (setq liece-minibuffer-map
  47         (let ((map (make-sparse-keymap)))
  48           (set-keymap-parent map minibuffer-local-map)
  49           (define-key map " " nil)
  50           (define-key map "\t" 'liece-minibuffer-complete)
  51           (define-key map "\r" 'exit-minibuffer)
  52           (define-key map "\n" 'exit-minibuffer)
  53           map)))
  54
  55 (defun liece-minibuffer-complete ()
  56   (interactive)
  57   (if (and liece-minibuffer-complete-function
  58            (fboundp liece-minibuffer-complete-function))
  59       (funcall liece-minibuffer-complete-function)))
  60
  61 (defun liece-minibuffer-parse-modes ()
  62   (save-excursion
  63     (let (preceding-char (state 'flag) type)
  64       (beginning-of-buffer)
  65       (while (not (eobp))
  66         (forward-char)
  67         (setq preceding-char (char-before))
  68         (cond
  69          ((and (eq state 'flag) (memq preceding-char '(+ ?-)))
  70           (setq state 'mode
  71                 type nil))
  72          ((and (eq state 'mode) (eq preceding-char ? ))
  73           (setq state 'arg))
  74          ((and (eq state 'mode) (memq preceding-char '(?o ?v)))
  75           (setq type (nconc type (list 'nick preceding-char
  76                                        (char-before (1- (point)))))))
  77          ((and (eq state 'mode) (eq preceding-char ?b))
  78           (setq type (nconc type (list 'ban (char-before (1- (point)))))))))
  79       (cons state type))))
  80
  81 (defun liece-minibuffer-prepare-candidate ()
  82   (let ((point (point)))
  83     (skip-syntax-backward "^ ")
  84     (prog1 (buffer-substring (point) point)
  85       (goto-char point))))
  86
  87 (defun liece-minibuffer-delete-candidate ()
  88   (let ((point (point)))
  89     (skip-syntax-backward "^ ")
  90     (delete-region (point) point)))
  91
  92 (defun liece-minibuffer-finalize-completion (completion pattern all)
  93   (cond
  94    ((eq completion t))
  95    ((null completion)
  96     (temp-minibuffer-message (_ "[No match]")))
  97    ((not (string= pattern completion))
  98     (liece-minibuffer-delete-candidate)
  99     (insert completion))
 100    (t
 101     (with-output-to-temp-buffer "*Completions*"
 102       (funcall completion-display-completion-list-function
 103                (sort all (function (lambda (x y)
 104                                      (string-lessp
 105                                       (or (car-safe x) x)
 106                                       (or (car-safe y) y))))))))))
 107
 108 (defun liece-minibuffer-complete-channel-modes ()
 109   (let* ((preceding-char (char-before)) completion candidate all
 110          (modes (mapconcat
 111                  (function car)
 112                  liece-supported-channel-mode-alist ""))
 113          (nicks (liece-channel-get-nicks))
 114          uahs
 115          (context (liece-minibuffer-parse-modes))
 116          (state (car context)) (type (cdr context)))
 117     (cond
 118      ((memq state '(flag mode))
 119       (temp-minibuffer-message
 120        (format (_ "[Modes are: %s]") modes)))
 121      ((and (eq state 'arg) (memq 'ban type))
 122       (if (memq ?- type)
 123           (setq uahs (list-to-alist (liece-channel-get-bans)))
 124         (setq uahs (mapcar
 125                     (function
 126                      (lambda (nick)
 127                        (list (concat nick "!"
 128                                      (liece-nick-get-user-at-host nick)))))
 129                     nicks)))
 130       (setq candidate (liece-minibuffer-prepare-candidate)
 131             completion (try-completion candidate uahs)
 132             all (all-completions candidate uahs)))
 133      ((and (eq state 'arg) (memq 'nick type))
 134       (let* ((masks (cond ((memq ?o type) (liece-channel-get-operators))
 135                           ((memq ?v type) (liece-channel-get-voices))))
 136              (nicks
 137               (if (memq ?- type)
 138                   masks
 139                 (remove-if
 140                  `(lambda (item)
 141                     (and (stringp item)
 142                          (string-list-member-ignore-case item ',masks)))
 143                  nicks))))
 144         (setq nicks (mapcar (function list) nicks)
 145               candidate (liece-minibuffer-prepare-candidate)
 146               completion (try-completion candidate nicks)
 147               all (all-completions candidate nicks)))))
 148     (liece-minibuffer-finalize-completion completion candidate all)))
 149
 150 (defun liece-minibuffer-complete-user-modes ()
 151   (temp-minibuffer-message
 152    (format
 153     (_ "[Modes are: %s]")
 154     (mapconcat (function car) liece-supported-user-mode-alist ""))))
 155
 156 (defun liece-minibuffer-completing-read
 157   (prompt table &optional predicate require-match initial-input history
 158           default)
 159   (let ((result
 160          (completing-read
 161           (if default
 162               (format "%s(default %s) " prompt default)
 163             prompt)
 164           table predicate require-match initial-input history)))
 165     (if (and default (equal result ""))
 166         default
 167       result)))
 168
 169 (defvar liece-minibuffer-completion-separator ","
 170   "Separator used for separating strings in `liece-minibuffer-completing-read-multiple'.
 171 It should be regular expression which doesn't match word-continuent characters.")
 172
 173 (defvar liece-minibuffer-completion-table nil)
 174
 175 (defun liece-minibuffer-completing-read-multiple-1 (string predicate flag)
 176   "Function used by `liece-minibuffer-completing-read-multiple'.
 177 The value of STRING is the string to be completed.
 178
 179 The value of PREDICATE is a function to filter possible matches, or
 180 nil if none.
 181
 182 The value of FLAG is used to specify the type of completion operation.
 183 A value of nil specifies `try-completion'.  A value of t specifies
 184 `all-completions'.  A value of lambda specifes a test for an exact match.
 185
 186 For more information on STRING, PREDICATE, and FLAG, see the Elisp
 187 Reference sections on 'Programmed Completion' and 'Basic Completion
 188 Functions'."
 189   (let ((except
 190          (split-string string liece-minibuffer-completion-separator))
 191         (table
 192          (copy-sequence liece-minibuffer-completion-table))
 193         lead)
 194     ;; Remove a partially matched word construct if it exists.
 195     (or (string-match
 196          (concat liece-minibuffer-completion-separator "$")
 197          string)
 198         (setq except (butlast except)))
 199     (when (string-match
 200            (concat ".*" liece-minibuffer-completion-separator)
 201            string)
 202       (setq lead (substring string 0 (match-end 0))
 203             string (substring string (match-end 0))))
 204     (while except
 205       (setq table (remassoc (car except) table)
 206             except (cdr except)))
 207     (if (null flag)
 208         (progn
 209           (setq string (try-completion string table predicate))
 210           (or (eq t string)
 211               (concat lead string)))
 212       (if (eq flag 'lambda)
 213           (eq t (try-completion string table predicate))
 214         (if flag
 215             (all-completions string table predicate))))))
 216
 217 (defun liece-minibuffer-completing-read-multiple
 218   (prompt table &optional predicate require-match initial-input
 219           history default multiple-candidate)
 220   "Execute `completing-read' consequently.
 221
 222 See the documentation for `completing-read' for details on the arguments:
 223 PROMPT, TABLE, PREDICATE, REQUIRE-MATCH, INITIAL-INPUT, HISTORY, DEFAULT."
 224   (let ((prompt
 225          (format "%s(punctuate by \"%s\") "
 226                  prompt liece-minibuffer-completion-separator)))
 227     (if multiple-candidate
 228         (let ((crm-separator
 229                liece-minibuffer-completion-separator))
 230           (completing-read-multiple
 231            prompt table predicate require-match initial-input
 232            history default))
 233       (let ((liece-minibuffer-completion-table
 234              table))
 235         (split-string
 236          (liece-minibuffer-completing-read
 237           prompt #'liece-minibuffer-completing-read-multiple-1
 238           predicate require-match initial-input history default)
 239          liece-minibuffer-completion-separator)))))
 240
 241 (provide 'liece-minibuf)
 242
 243 ;;; liece-minibuf.el ends here