home *** CD-ROM | disk | FTP | other *** search
/ Fresh Fish 8 / FreshFishVol8-CD1.bin / new / util / edit / jade / lisp / prompt.jl < prev    next >
Lisp/Scheme  |  1994-10-03  |  13KB  |  404 lines
  1. ;;;; prompt.jl -- Prompt in a buffer with completion
  2. ;;;  Copyright (C) 1993, 1994 John Harper <jsh@ukc.ac.uk>
  3.  
  4. ;;; This file is part of Jade.
  5.  
  6. ;;; Jade is free software; you can redistribute it and/or modify it
  7. ;;; under the terms of the GNU General Public License as published by
  8. ;;; the Free Software Foundation; either version 2, or (at your option)
  9. ;;; any later version.
  10.  
  11. ;;; Jade is distributed in the hope that it will be useful, but
  12. ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  13. ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14. ;;; GNU General Public License for more details.
  15.  
  16. ;;; You should have received a copy of the GNU General Public License
  17. ;;; along with Jade; see the file COPYING.  If not, write to
  18. ;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  19.  
  20. (defvar prompt-keymap (make-keylist))
  21.  
  22. (defvar prompt-buffer-list '()
  23.   "Stack of buffers which can be used for prompts.")
  24.  
  25. (bind-keys prompt-keymap
  26.   "TAB"        'prompt-complete-word
  27.   "RET"        'prompt-enter-line
  28.   "LMB-CLICK2"    'prompt-select-completion
  29.   "RMB-CLICK1"    'prompt-complete-word
  30.   "Meta-?"    'prompt-print-word-completions
  31.   "Ctrl-g"    'prompt-cancel)
  32.  
  33.  
  34. ;; Configuration variables
  35.  
  36. (defvar prompt-completion-function nil
  37.   "Optional function taking one argument, the string to be completed. It
  38. should return a list of all matches.")
  39.  
  40. (defvar prompt-validate-function nil
  41.   "Optional function taking one argument, the string which has been entered.
  42. Should return non-nil when this string may be accepted (and therefore the
  43. prompt will end). If it returns the symbol t the string is returned as-is,
  44. if some other non-nil value is returned *that* is the value returned by
  45. the prompt.")
  46.  
  47. (defconst prompt-def-regexps ["." "^|$"]
  48.   "Default value of `prompt-word-regexps'")
  49.  
  50. (defvar prompt-word-regexps prompt-def-regexps
  51.   "Vector of two regexps; the values of `word-regexp' and `word-not-regexp'
  52. for the prompt.")
  53.  
  54. (defvar prompt-list nil
  55.   "Used by the `prompt-complete-from-list' and `prompt-validate-from-list'
  56. to supply possible completions.")
  57.  
  58. (defvar prompt-symbol-predicate nil
  59.   "Predicate used when prompting for symbols.")
  60.  
  61. (defvar amiga-use-file-req-p t
  62.   "*AMIGA ONLY*
  63. When non-nil the normal ASL file requester is used when file names are
  64. prompted for.")
  65.  
  66.  
  67. (defvar prompt-buffer nil
  68.   "The buffer being used for the prompt.")
  69.  
  70. (defvar prompt-completions-pos nil
  71.   "Position at which the list of completions should be printed.")
  72.  
  73.  
  74. ;; Main entrypoint
  75.  
  76. (defun prompt2 (&optional title start)
  77.   "Prompts for a string using completion. TITLE is the optional title to
  78. print in the buffer, START the original contents of the buffer.
  79. The string entered is returned, or nil if the prompt is cancelled (by Ctrl-g)."
  80.   (let*
  81.       (prompt-buffer
  82.        prompt-line-pos
  83.        prompt-completions-pos
  84.        result)
  85.     (if prompt-buffer-list
  86.     (setq prompt-buffer (car prompt-buffer-list)
  87.           prompt-buffer-list (cdr prompt-buffer-list))
  88.       (setq prompt-buffer (make-buffer "*prompt*")))
  89.     (setq buffer-list (cons prompt-buffer buffer-list))
  90.     (set-buffer-special prompt-buffer t)
  91.     (with-buffer prompt-buffer
  92.       (setq word-regexp (aref prompt-word-regexps 0) 
  93.         word-not-regexp (aref prompt-word-regexps 1))
  94.       (if (stringp title)
  95.       (insert title)
  96.     (insert "Enter string:"))
  97.       (if (stringp start)
  98.       (format (current-buffer) "\n\n%s\n\n" start)
  99.     (insert "\n\n\n\n"))
  100.       (insert "::Completions::\n")
  101.       (setq prompt-completions-pos (cursor-pos))
  102.       (goto-char (line-end (prev-line 3)))
  103.       (setq keymap-path '(prompt-keymap global-keymap)
  104.         buffer-undo-list nil
  105.         result (catch 'prompt (recursive-edit))
  106.         buffer-list (delq prompt-buffer buffer-list)))
  107.     (clear-buffer prompt-buffer)
  108.     (setq prompt-buffer-list (cons prompt-buffer prompt-buffer-list))
  109.     result))
  110.  
  111.  
  112. ;; Subroutines
  113.  
  114. (defun prompt-enter-line (&optional whole-line)
  115.   (interactive)
  116.   (let*
  117.       ((pos (if (and (> (cursor-pos) prompt-completions-pos)
  118.              whole-line)
  119.         (line-end)
  120.           (cursor-pos)))
  121.        (line (copy-area (line-start) pos)))
  122.     (if (or (not prompt-validate-function)
  123.         (let
  124.         ((res (funcall prompt-validate-function line)))
  125.           (when (and res (not (eq res t)))
  126.         (setq line res))
  127.           res))
  128.     (throw 'prompt line)
  129.       (beep))))
  130.  
  131. (defun prompt-select-completion ()
  132.   (interactive)
  133.   (goto-char (mouse-pos))
  134.   (prompt-enter-line t))
  135.  
  136. ;; Returns the number of completions found.
  137. (defun prompt-complete-word ()
  138.   (interactive)
  139.   (if (not prompt-completion-function)
  140.       (progn
  141.     (message "No completion in this prompt!")
  142.     0)
  143.     (let*
  144.     ((word-pos (or (word-start (left-char))
  145.                (line-start)))
  146.      (word (copy-area word-pos (cursor-pos)))
  147.      (comp-list (funcall prompt-completion-function word))
  148.      (num-found (length comp-list))
  149.      (buffer-record-undo nil))
  150.       (cond
  151.        ((= num-found 0)
  152.     (delete-area prompt-completions-pos (buffer-end))
  153.     (message "No completions."))
  154.        ((= num-found 1)
  155.     (goto-char (replace-string word (car comp-list) word-pos))
  156.     (delete-area prompt-completions-pos (buffer-end))
  157.     (message "Unique completion."))
  158.        (t
  159.     (prompt-print-completions comp-list)
  160.     (when (not (string-head-eq (car comp-list) word))
  161.       ;; Completions don't match their source at all.
  162.       (delete-area word-pos (cursor-pos))
  163.       (setq word ""))
  164.     (goto-char (replace-string word
  165.                    (make-completion-string word comp-list)
  166.                    word-pos))
  167.     (format t "%d completions." num-found)))
  168.       num-found)))
  169.  
  170. (defun prompt-print-completions (comp-list)
  171.   (let*
  172.       ((ipos (copy-pos prompt-completions-pos))
  173.        ;; Don't want to record undo information for the completion list
  174.        (buffer-record-undo nil))
  175.     (delete-area ipos (buffer-end))
  176.     (insert "\n" ipos)
  177.     (while (consp comp-list)
  178.       (format (cons (current-buffer) ipos) "%s\n" (car comp-list))
  179.       (setq comp-list (cdr comp-list)))))
  180.  
  181. (defun prompt-print-word-completions ()
  182.   (interactive)
  183.   (prompt-print-completions
  184.    (funcall prompt-comp-func
  185.         (copy-area (or (word-start (left-char))
  186.                (line-start))
  187.                (cursor-pos)))))
  188.  
  189. (defun prompt-cancel ()
  190.   (interactive)
  191.   (message "Quit!")
  192.   (throw 'prompt nil))
  193.  
  194.  
  195. ;; Various completion/validation functions
  196.  
  197. (defun prompt-complete-symbol (word)
  198.   (mapcar 'symbol-name (apropos (concat ?^ word) prompt-symbol-predicate)))
  199.  
  200. (defun prompt-validate-symbol (name)
  201.   (and (find-symbol name)
  202.        (or (not prompt-symbol-predicate)
  203.        (funcall prompt-symbol-predicate (find-symbol name)))))
  204.  
  205. (defun prompt-complete-buffer (word)
  206.   (delete-if-not #'(lambda (b)
  207.              (string-head-eq b word))
  208.          (mapcar 'buffer-name buffer-list)))
  209.  
  210. (defun prompt-validate-buffer (name)
  211.   (if (equal name "")
  212.       t
  213.     (get-buffer name)))
  214.  
  215. (defvar prompt-file-exclude '"\\.(o|jlc|x)$|~$|^#.*#$"
  216.   "A regexp, if it matches the file being considered for completion, the file
  217. is rejected.")
  218.  
  219. ;; Don't want .info files (WB icons) on Amigas, everywhere else they're okay
  220. ;; though.
  221. (when (amiga-p)
  222.   (setq prompt-file-exclude (concat prompt-file-exclude "|\\.info$")))
  223.  
  224. ;; Ignore the `.' and `..' directory entries in UNIX
  225. (when (unix-p)
  226.   (setq prompt-file-exclude (concat prompt-file-exclude "|^\\.(\\.|)$")))
  227.  
  228. (defun prompt-complete-filename (word)
  229.   (setq word (expand-file-name word))
  230.   (let*
  231.       ((path (file-name-directory word))
  232.        (file (file-name-nondirectory word))
  233.        (files (directory-files path)))
  234.     (mapcar #'(lambda (x &aux y) 
  235.         (when (file-directory-p (setq y (concat path x)))
  236.           (setq y (concat y ?/)))
  237.         y)
  238.         (delete-if #'(lambda (f)
  239.                (or (not (string-head-eq f file))
  240.                    (regexp-match prompt-file-exclude f)))
  241.                files))))
  242.  
  243. (defun prompt-validate-filename (name)
  244.   (file-exists-p name))
  245.  
  246. (defun prompt-complete-directory (word)
  247.   (setq word (expand-file-name word))
  248.   (let
  249.       ((path (file-name-directory word))
  250.        (file (file-name-nondirectory word)))
  251.     (delq 'nil
  252.       (mapcar #'(lambda (x)
  253.               (when (file-directory-p (concat path x))
  254.             (concat path x ?/)))
  255.           (delete-if #'(lambda (f)
  256.                  (not (string-head-eq f file)))
  257.                  (directory-files path))))))
  258.  
  259. (defun prompt-validate-directory (name)
  260.   (file-directory-p name))
  261.  
  262.