[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]


I have posted this to cambridge.apple.com:/pub/MCL/contrib
as symbol-complete.lisp.

  From: Repenning Alexander <ralex@tigger.cs.colorado.edu>
  Subject: File for MCL 2.0 CD-ROM
  To: straz@cambridge.apple.com

  It's (yet another) symbol completer. It has been used for a while -
  not only by me. As a result the thing has become quite simple. All the
  power user geek modifier keys to do wild variations of completions are
  gone and have been replaced with a simple but powerfull one-button
  completion mechanism.


--------------X   symbol-complete.lisp X-----------------
;;; -*- package: ccl -*-
;*                                                                   *
;*    PROGRAM      S Y M B O L   C O M P L E T I O N                 *
;*    PACKAGE      :ccl                                              *
;*                                                                   *
   ;* Author    : Alex Repenning                                     *
   ;* Copyright : (C) University of Colorado at Boulder              *
   ;*             Computer Science Department                        *
   ;*             Boulder, CO 80303                                  *
   ;*             07/24/90                                           *
   ;* Filename         : symbol-complete.lisp                        *
   ;* Last Update      : 2/27/92                                     *
   ;* Version   :                                                    *
   ;*   1.0   07/24/90  Alex Repenning                               *
   ;*   1.1   04/13/91  Alex & Brigham Bell   completion works also  *
   ;*                   if cursor in the middle of symbol.           *
   ;*   2.0    1/ 6/92  Alex, MCL 2.0                                *
   ;* System    : Macintosh II, MCL 2.0                              *
   ;* Abstract  : A simple line completion mechanism.                *
   ;* Features:                                                      *
   ;*   - Simple one key operation: Since most users do not like to  *
   ;*       remember many different completion functions, this       *
   ;*       completion package combines several completion           *
   ;*       strategies into one function (using a cascading filter   *
   ;*       scheme).                                                 *
   ;*         1) prefix search in window package                     *
   ;*         2) prefix search in all packages                       *
   ;*         3) substring search in window package                  *
   ;*         4) substring search in all packages                    *
   ;*       If no symbol is found the next strategy is employed.     *
   ;*       If only one symbol is found it will be used as           *
   ;*       completion.                                              *
   ;*       If multiple symbols are found then either the symbol     *
   ;*       is completed as far as possible or a menu is offered.    *
   ;*   - Partial Completion (sounds like a contradiction):          *
   ;*       If at any stage in the search there is more than one     *
   ;*       interned symbol matching what you typed so far and if    *
   ;*       the common prefix of these symbols is longer than what   *
   ;*       is typed so far you will get this common prefix.         *
   ;*   - Preserves Case: The completion will assume the same case   *
   ;*       of the string typed so far (lower case, upper case, or   *
   ;*       capitalized),                                            *
   ;*       e.g., "*Apple-" gets completed to "*Apple-Menu*"         *
   ;*   - Works also with Dialog Boxes                               *
   ;*   - It's Small: more comments than code ;-)                    *
   ;* Bugs, Problems: Haven't found a good strategy yet to deal with *
   ;*   package prefixes of partial completions:                     *
   ;*    - use partial completion only if all symbol from same       *
   ;*      package?                                                  *
   ;*    - strip package prefix?                                     *
   ;*      Any ideas?                                                *
   ;*   Completion can be slow in very crowded packages (e.g., :ccl) *
   ;*                                                                *

(in-package :ccl)

(defvar *Maximum-Pop-up-Size* 100
  "if the number of matches exceeds this number then warn user")

;  high-level completion functions             |

(defmethod COMPLETE-SYMBOL ((Self fred-mixin)) "
  in: Self {fred-mixin}.
  Try to complete the selected symbol using a decreasingly constraining
  search through existing (interened) symbols."
  (let ((*Package* (or (window-package Self) *Package*)))
    (multiple-value-bind (String Start End Package) (selected-symbol-string Self)
      (when String
          (search-for-matching-symbols Self (string-upcase String) Package))

(defmethod SELECTED-SYMBOL-STRING ((Self fred-mixin)) "
  in:  Self {fred-mixin}.
  out: String {string} or nil, Start {position}, End {position}, Package {string}.
  Return the selected symbol (the one highlighted or just being to the
  left of the insertion marker."
  (let ((Mark (fred-buffer Self)))
    (multiple-value-bind (Start End) (buffer-current-sexp-bounds Mark)
      (when Start 
        (let* ((Start (case (buffer-char Mark Start)
                        (#\' (1+ Start))
                        (t Start)))
               (String (buffer-substring Mark End Start)))
           (string->name String)
           (package-name (gracefully-find-package 
                          (or (string->package String) 
                              (window-package Self)

(defmethod CHOOSE-ONE-SYMBOL-NAME ((Self fred-mixin) String Symbols) "
  in:  Self {fred-mixin}, String {string}, Symbols {list of: {symbol}}.
  out: Name {string}.
  Pick a symbol close to <String> using the following strategy:
  |<Symbols>| = 0 -> <String>
  |<Symbols>| = 1 -> (first <Symbols>)
  |<Symbols>| > 1  and |common-prefix| = 0 -> user-choice
  |<Symbols>| > 1  and |common-prefix| > 0 -> common-prefix."
  (case (length Symbols)
    (0 (format (view-mini-buffer Self) "no matches") String)
    (1 (prin1-to-string (first Symbols)))
    (t (let ((Prefix (common-symbol-name-prefix Symbols)))
         (if (> (length Prefix) (length String))
            ((<= (length Symbols) *Maximum-Pop-Up-Size*)
             (prin1-to-string (first (select-item-from-list 
                                      :window-title "select completion"
                                      :table-print-function #'prin1))))
             (format (view-mini-buffer Self) "too many matches: ~A" (length Symbols))

  (let ((First-String (symbol-name (first Symbols))))
    (with-output-to-string (S)
      (block done
        (dotimes (I (length First-String))
          (let ((Char (char First-String I)))
            (dolist (String (mapcar #'symbol-name (rest Symbols)) (princ Char S))
              (when (or (> I (length String)) (char/= (char String I) Char))
                (return-from done nil)))))))))

(defmethod SEARCH-FOR-MATCHING-SYMBOLS ((Self fred-mixin) String Package) "
  in:  Self {fred-mixin}, String {string}, Package {string}.
  out: Matches {list of: {symbol}}. "
  ; 1) search prefix, same package
  (let ((MB (view-mini-buffer Self)))
    (format MB ".")
    (mini-buffer-update Self)
    (let* ((Local-Symbols (apropos-list String Package))
           (Symbols (matching-prefix-symbols String Local-Symbols)))
      (if Symbols
        ; 2) search prefix, all packages
          (format MB ".")
          (mini-buffer-update Self)
          (let* ((Global-Symbols (apropos-list String))
                 (Symbols (matching-prefix-symbols String Global-Symbols)))
            (if Symbols
              ; 3) search substring, same package
                (format MB ".")
                (mini-buffer-update Self)
                (if Local-Symbols
                  ; 4) return any match: substring in all packages
                    (format MB ".")
                    (mini-buffer-update Self)

(defun MATCHING-PREFIX-SYMBOLS (String Symbols) "
  in:  String {string}, Symbols {list of: {symbol}}.
  out: Symbols {list of: {symbol}}.
  Return only the symbols of which <String> is a prefix."
  (let ((L (length String)))
     #'(lambda (Symbol) (string= String (symbol-name Symbol) :end1 L :end2 L))

;  low-level functions                         |

(defmethod BUFFER-REPLACE-STRING ((Self fred-mixin) Start End String &optional Old-String) "
  in:  Self {fred-mixin}, Start End {position}, String {string}, 
       &optional Old-String {string}.
  Delete the buffer content between <Start> and <End>, insert
  <String> and place insertion marker to <End> position."
  (let ((Mark (fred-buffer Self)))
    (buffer-delete Mark Start End)
     (if Old-String
       (case (string-format Old-String)
         (:upper (string-upcase String))
         (:lower (string-downcase String))
         (:capital (string-capitalize String)))

(defun STRING-FORMAT (String) "
  in:  String {string}.
  out: Capitalization {keyword} :upper, :lower :capital.
  Return the capitalization status of a string"
  (case (length String)
    (0 :lower)
    (1 (if (lower-case-p (char String 0)) :lower :upper))
    (t (if (char= (char String 0) #\*)
         (string-format (subseq String 1))
         (if (upper-case-p  (char String 0))
           (if (upper-case-p (char String 1))

  in:  Package {string}.
  out: Package {string}.
  If FIND-PACKAGE doesn't find <Package> then prompt the user for an
  (or (find-package Package) 
       (first (select-item-from-list 
               (mapcar #'package-name (list-all-packages))
               :window-title "Select an existing Package")))))

(defun STRING->PACKAGE (String) "
  in:  String {string}. out: Package {string} or nil.
  Return package prefix of string (if any)"
  (let ((P (position #\: String)))
    (when P
      (if (zerop P)
        (string-upcase (subseq String 0 P))))))

(defun STRING->NAME (String) "
  in: String {string}. out: Name {string}.
  Return <string> without a package prefix."
  (let ((P (position #\: String)))
    (if P
      (string-left-trim ":" (subseq String P))

;  keyboard bindings                           |

;this overwrites the set-mark EMACS command
(comtab-set-key *Comtab* '(:control #\space) 'complete-symbol)
#| stuff:

(common-symbol-name-prefix '(bla-lkfdflkdf blappppppp bla)) -> "BLA"
(common-symbol-name-prefix (apropos-list "WITH-OP")) -> "WITH-OPEN-"

(string->package "dsdsd")  -> nil
(string->package "ccl::gc")  -> "CCL"
(string->package ":rest") -> "KEYWORD"