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