/[mcclim]/mcclim/Drei/abbrev.lisp
ViewVC logotype

Contents of /mcclim/Drei/abbrev.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.2 - (show annotations)
Sat Dec 8 08:53:50 2007 UTC (6 years, 4 months ago) by thenriksen
Branch: MAIN
CVS Tags: McCLIM-0-9-6, HEAD
Changes since 1.1: +1 -1 lines
Changed Drei to use a view-based paradigm, didn't make any significant
changes to ESA just yet.
1 ;;; -*- Mode: Lisp; Package: DREI-ABBREV -*-
2
3 ;;; (c) copyright 2004 by
4 ;;; Robert Strandh (strandh@labri.fr)
5 ;;; (c) copyright 2004 by
6 ;;; Elliott Johnson (ejohnson@fasl.info)
7
8 ;;; This library is free software; you can redistribute it and/or
9 ;;; modify it under the terms of the GNU Library General Public
10 ;;; License as published by the Free Software Foundation; either
11 ;;; version 2 of the License, or (at your option) any later version.
12 ;;;
13 ;;; This library is distributed in the hope that it will be useful,
14 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
15 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
16 ;;; Library General Public License for more details.
17 ;;;
18 ;;; You should have received a copy of the GNU Library General Public
19 ;;; License along with this library; if not, write to the
20 ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
21 ;;; Boston, MA 02111-1307 USA.
22
23 ;;; Abbrevs are expanded by a call to the generic function
24 ;;; expand-abbrev. That function takes a word to be expanded and an
25 ;;; instance of the class abbrev-expander and returns either NIL
26 ;;; (meaning there was no expansion for this word) or another string
27 ;;; which is the expansion of the word.
28 ;;;
29 ;;; We define a particular sublcass of abbrev-expander which just
30 ;;; contains a dictionary (an alist) of <word,expansion> pairs and
31 ;;; which does case-mangling on the expansion according to the case of
32 ;;; the word. Client code would typically create other subclasses of
33 ;;; abbrev-expander that can do more sophisticated abbrev expansion.
34
35 (in-package :drei-abbrev)
36
37 ;;; the protocol class for all abbrev expanders.
38 (defclass abbrev-expander () ()
39 (:documentation "The protocol class for all abbreviation expanders"))
40
41 (defgeneric expand-abbrev (word abbrev-expander)
42 (:documentation "Given a word and an abbrev expander, return the
43 expanded abbrev, or NIL if no expansion exists"))
44
45 (defclass dictionary-abbrev-expander (abbrev-expander)
46 ((dictionary :initform '() :accessor dictionary
47 :documentation "A dictionary of abbreviations."))
48 (:documentation "A protocol class specified for dictionary abbreviation expanders."))
49
50 (defgeneric add-abbrev (word expansion dictionary-abbrev-expander)
51 (:documentation "Add an abbrev expansion to a dictionary abbrev expander"))
52
53 (defmethod add-abbrev (word expansion (expander dictionary-abbrev-expander))
54 (push (cons word expansion) (dictionary expander)))
55
56 (defun string-upper-case-p (string)
57 "A predicate testing if each character of a string is uppercase."
58 (every #'upper-case-p string))
59
60 (defmethod expand-abbrev (word (expander dictionary-abbrev-expander))
61 "Expands an abbrevated word by attempting to assocate it with a member of
62 an abbreviation dictionary. If such an association is found, an uppercase,
63 expanded version of the abbrevation is returned."
64 (let ((expansion (cdr (assoc word (dictionary expander) :test #'string-equal))))
65 (when expansion
66 (cond ((string-upper-case-p word) (string-upcase expansion))
67 ((upper-case-p (aref word 0)) (string-capitalize expansion))
68 (t expansion)))))
69
70 (defun possibly-expand-abbrev (mark)
71 "Replaces a bit of abbreviated text with its fully expanded counterpart."
72 (let ((buffer (buffer mark)))
73 (when (and (not (beginning-of-buffer-p mark))
74 (constituentp (object-before mark)))
75 (let ((offset1 (offset mark))
76 (offset2 (offset mark)))
77 (loop until (zerop offset1)
78 while (constituentp (buffer-object buffer (1- offset1)))
79 do (decf offset1))
80 (let ((expansion (expand-abbrev (coerce (buffer-sequence buffer offset1 offset2)
81 'string)
82 (abbrev-expander (implementation buffer)))))
83 (when expansion
84 (delete-buffer-range buffer offset1 (- offset2 offset1))
85 (insert-buffer-sequence buffer offset1 expansion)))))))
86
87 (defclass abbrev-mixin ()
88 ((expander :initform (make-instance 'dictionary-abbrev-expander)
89 :initarg :expander :accessor abbrev-expander))
90 (:documentation "A mixin class which adds abbreviation expansion facilities to
91 a buffer via the accessor \"abbrev-expander\""))

  ViewVC Help
Powered by ViewVC 1.1.5