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