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 default)
 155   (completing-read
 156    (if default
 157        (format "%s(default %s) " prompt default)
 158      prompt)
 159    table predicate require-match initial-input history default))
 160
 161 (defvar liece-minibuffer-completion-separator ","
 162   "Separator used for separating strings in `liece-minibuffer-completing-read-multiple'.
 163 It should be regular expression which doesn't match word-continuent characters.")
 164
 165 (defvar liece-minibuffer-completion-table nil)
 166
 167 (defun liece-minibuffer-completing-read-multiple-1 (string predicate flag)
 168   "Function used by `liece-minibuffer-completing-read-multiple'.
 169 The value of STRING is the string to be completed.
 170
 171 The value of PREDICATE is a function to filter possible matches, or
 172 nil if none.
 173
 174 The value of FLAG is used to specify the type of completion operation.
 175 A value of nil specifies `try-completion'.  A value of t specifies
 176 `all-completions'.  A value of lambda specifes a test for an exact match.
 177
 178 For more information on STRING, PREDICATE, and FLAG, see the Elisp
 179 Reference sections on 'Programmed Completion' and 'Basic Completion
 180 Functions'."
 181   (let ((except
 182          (split-string string liece-minibuffer-completion-separator))
 183         (table
 184          (copy-sequence liece-minibuffer-completion-table))
 185         lead)
 186     ;; Remove a partially matched word construct if it exists.
 187     (or (string-match
 188          (concat liece-minibuffer-completion-separator "$")
 189          string)
 190         (setq except (butlast except)))
 191     (when (string-match
 192            (concat ".*" liece-minibuffer-completion-separator)
 193            string)
 194       (setq lead (substring string 0 (match-end 0))
 195             string (substring string (match-end 0))))
 196     (while except
 197       (setq table (remassoc (car except) table)
 198             except (cdr except)))
 199     (if (null flag)
 200         (progn
 201           (setq string (try-completion string table predicate))
 202           (or (eq t string)
 203               (concat lead string)))
 204       (if (eq flag 'lambda)
 205           (eq t (try-completion string table predicate))
 206         (if flag
 207             (all-completions string table predicate))))))
 208
 209 (defun liece-minibuffer-completing-read-multiple
 210   (prompt table &optional predicate require-match initial-input
 211           history default multiple-candidate)
 212   "Execute `completing-read' consequently.
 213
 214 See the documentation for `completing-read' for details on the arguments:
 215 PROMPT, TABLE, PREDICATE, REQUIRE-MATCH, INITIAL-INPUT, HISTORY, DEFAULT."
 216   (let ((prompt
 217          (format "%s(punctuate by \"%s\") "
 218                  prompt liece-minibuffer-completion-separator)))
 219     (if multiple-candidate
 220         (let ((crm-separator
 221                liece-minibuffer-completion-separator))
 222           (completing-read-multiple
 223            prompt table predicate require-match initial-input
 224            history default))
 225       (let ((liece-minibuffer-completion-table
 226              table))
 227         (split-string
 228          (completing-read
 229           prompt #'liece-minibuffer-completing-read-multiple-1
 230           predicate require-match initial-input history default)
 231          liece-minibuffer-completion-separator)))))
 232
 233 (provide 'liece-minibuf)
 234
 235 ;;; liece-minibuf.el ends here