home *** CD-ROM | disk | FTP | other *** search
/ Fresh Fish 5 / FreshFish_July-August1994.bin / bbs / util / jade-3.0.lha / Jade / lisp / prompt.jl < prev    next >
Encoding:
Text File  |  1994-04-19  |  6.9 KB  |  198 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. (setq
  21.   prompt-keymap (make-keylist)
  22.   prompt-esc-keymap (make-keylist)
  23.   ;; stack of buffers which can be used for prompts
  24.   prompt-buffer-list ())
  25.  
  26. (bind-keys prompt-keymap
  27.   "esc"     '(setq next-keymap-path '(prompt-esc-keymap esc-keymap))
  28.   "tab"     'prompt-complete-word
  29.   "return"  'prompt-enter-line
  30.   "ctrl-g"  '(throw 'prompt nil))
  31. (bind-keys prompt-esc-keymap
  32.   "?"       'prompt-print-word-completions)
  33.  
  34. (defun prompt2 (prompt-comp-func &optional prompt-title prompt-start word-regexps)
  35.   "(prompt2 COMP-FUNC [TITLE] [START] [WORD-REGEXPS])
  36. Prompts for a string using completion. COMP-FUNC is a function which takes
  37. one argument, the string which should be completed. It should return a list
  38. of all matches. TITLE is the optional title to print in the buffer, START the
  39. original contents of the buffer. WORD-REGEXPS is a vector of two regexps
  40. corresponding to the values of `word-regexp' and `word-not-regexp' for the
  41. completion mechanism.
  42. The string entered is returned, or nil if the prompt is cancelled (by Ctrl-g)."
  43.   (let*
  44.       (prompt-buffer
  45.        prompt-line-pos
  46.        prompt-completions-pos
  47.        result)
  48.     (if prompt-buffer-list
  49.     (setq
  50.       prompt-buffer (car prompt-buffer-list)
  51.       prompt-buffer-list (cdr prompt-buffer-list))
  52.       (setq prompt-buffer (make-buffer "*prompt*")))
  53.     (setq buffer-list (cons prompt-buffer buffer-list))
  54.     (set-buffer-special prompt-buffer t)
  55.     (with-buffer prompt-buffer
  56.       (if word-regexps
  57.       (setq
  58.         word-regexp (aref word-regexps 0)
  59.         word-not-regexp (aref word-regexps 1))
  60.     (setq
  61.       word-regexp "."
  62.       word-not-regexp "^|$"))
  63.       (if (stringp prompt-title)
  64.       (insert prompt-title)
  65.     (insert "Enter string:"))
  66.       (split-line)
  67.       (if (stringp prompt-start)
  68.       (format (current-buffer) "\n%s\n\n" prompt-start)
  69.     (insert "\n\n\n"))
  70.       (insert "::Completions::\n")
  71.       (setq prompt-completions-pos (cursor-pos))
  72.       (goto (line-end (prev-line 3)))
  73.       (setq keymap-path '(prompt-keymap global-keymap))
  74.       (setq prompt-line-pos (catch 'prompt (recursive-edit)))
  75.       (setq buffer-list (delq prompt-buffer buffer-list))
  76.       (when (posp prompt-line-pos)
  77.     (setq result (copy-area (line-start prompt-line-pos) prompt-line-pos))))
  78.     (clear-buffer prompt-buffer)
  79.     (setq prompt-buffer-list (cons prompt-buffer prompt-buffer-list))
  80.     result))
  81.  
  82. (defun prompt-enter-line ()
  83.   (throw 'prompt (if (> (cursor-pos) prompt-completions-pos)
  84.     (line-end)
  85.       (cursor-pos))))
  86.  
  87. (defun prompt-complete-word ()
  88.   (let*
  89.       (word
  90.        word-pos
  91.        comp-list
  92.        num-found)
  93.     (setq
  94.       word-pos (unless (word-start (left-char)) (line-start))
  95.       word (copy-area word-pos (cursor-pos))
  96.       comp-list (funcall prompt-comp-func word)
  97.       num-found (length comp-list))
  98.     (cond
  99.       ((= num-found 0)
  100.     (beep)
  101.     (delete-area prompt-completions-pos (file-end))
  102.     (title "No completions."))
  103.       ((= num-found 1)
  104.     (goto (replace-string word (car comp-list) word-pos))
  105.     (delete-area prompt-completions-pos (file-end))
  106.     (title "Unique completion."))
  107.       (t
  108.     (beep)
  109.     (prompt-print-completions comp-list)
  110.     (goto (replace-string word (make-completion-string word comp-list) word-pos))
  111.     (format t "%d completions." num-found)))))
  112.  
  113. (defun prompt-print-completions (comp-list &optional insert-pos)
  114.   (let*
  115.       ((ipos (dup-pos prompt-completions-pos)))
  116.     (delete-area ipos (file-end))
  117.     (insert "\n" ipos)
  118.     (while (consp comp-list)
  119.       (format (cons (current-buffer) ipos) "%s\n" (car comp-list))
  120.       (setq comp-list (cdr comp-list)))))
  121.  
  122. (defun prompt-print-word-completions ()
  123.   (prompt-print-completions
  124.     (funcall prompt-comp-func
  125.          (copy-area (unless (word-start (left-char))
  126.               (line-start)) (cursor-pos)))))
  127.  
  128. (defun prompt-complete-symbol (word)
  129.   (mapcar 'symbol-name (apropos (concat ?^ word))))
  130. (defun prompt-complete-function (word)
  131.   (mapcar 'symbol-name (apropos (concat ?^ word) 'fboundp)))
  132. (defun prompt-complete-variable (word)
  133.   (mapcar 'symbol-name (apropos (concat ?^ word) 'boundp)))
  134. (defun prompt-complete-buffer (word)
  135.   (delete-if-not #'(lambda (b) (string-head-eq b word))
  136.          (mapcar 'buffer-name buffer-list)))
  137.  
  138. (defun prompt-complete-filename (word)
  139.   (let*
  140.       ((path (path-name word))
  141.        (file (base-name word))
  142.        (files (directory-files path)))
  143.     (mapcar
  144.      #'(lambda (x &aux y) 
  145.     (when (file-directory-p (setq y (concat path x)))
  146.       (setq y (concat y ?/)))
  147.     y)
  148.      (delete-if-not #'(lambda (f) (string-head-eq f file)) files))))
  149.  
  150. (defun prompt-for-file (&optional prompt start-name)
  151.   (unless (stringp prompt)
  152.     (setq prompt "Enter filename:"))
  153.   (prompt2 'prompt-complete-filename prompt start-name))
  154.  
  155. (defun prompt-for-buffer (&optional prompt start)
  156.   (when (bufferp start)
  157.     (setq start (buffer-name start)))
  158.   (unless (stringp prompt)
  159.     (setq prompt "Enter buffer name:"))
  160.   (prompt2 'prompt-complete-buffer prompt start))
  161.  
  162. (defun prompt-for-symbol (&optional prompt start)
  163.   (when (and (symbolp start) (not (null start)))
  164.     (setq start (symbol-name start)))
  165.   (unless (stringp prompt)
  166.     (setq prompt "Enter name of symbol:"))
  167.   (intern (prompt2 'prompt-complete-symbol prompt start symbol-word-regexps)))
  168.  
  169. (defun lisp-prompt (prompt &optional start)
  170.   (prompt2 'prompt-complete-symbol prompt start symbol-word-regexps))
  171.  
  172. (defun prompt-for-function (&optional prompt start)
  173.   (when (and (symbolp start) (not (null start)))
  174.     (setq start (symbol-name start)))
  175.   (unless (stringp prompt)
  176.     (setq prompt "Enter name of function:"))
  177.   (intern (prompt2 'prompt-complete-function prompt start symbol-word-regexps)))
  178.  
  179. (defun prompt-for-variable (&optional prompt start)
  180.   (when (and (symbolp start) (not (null start)))
  181.     (setq start (symbol-name start)))
  182.   (unless (stringp prompt)
  183.     (setq prompt "Enter name of variable:"))
  184.   (intern (prompt2 'prompt-complete-variable prompt start symbol-word-regexps)))
  185.  
  186. (defun prompt-complete-from-list (word)
  187.   (let
  188.       ((src prompt-list)
  189.        (dst ()))
  190.     (while src
  191.       (when (string-head-eq (car src) word)
  192.     (setq dst (cons (car src) dst)))
  193.       (setq src (cdr src)))
  194.     dst))
  195.  
  196. (defun prompt-from-list (prompt-list prompt &optional start)
  197.   (prompt2 'prompt-complete-from-list prompt start))
  198.