source: trunk/source/cocoa-ide/hemlock/src/modeline.lisp @ 12323

Last change on this file since 12323 was 12323, checked in by gb, 10 years ago

Modline's "buffer modified" indicator: check to see if the document's
modified.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 8.0 KB
Line 
1;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*-
2;;;
3;;; **********************************************************************
4;;; This code was written as part of the CMU Common Lisp project at
5;;; Carnegie Mellon University, and has been placed in the public domain.
6
7(in-package :hemlock-internals)
8
9
10;;;; Modelines-field structure support.
11
12(defun print-modeline-field (obj stream ignore)
13  (declare (ignore ignore))
14  (write-string "#<Hemlock Modeline-field " stream)
15  (prin1 (modeline-field-%name obj) stream)
16  (write-string ">" stream))
17
18(defun print-modeline-field-info (obj stream ignore)
19  (declare (ignore ignore))
20  (write-string "#<Hemlock Modeline-field-info " stream)
21  (prin1 (modeline-field-%name (ml-field-info-field obj)) stream)
22  (write-string ">" stream))
23
24
25(defvar *modeline-field-names* (make-hash-table))
26
27(defun make-modeline-field (&key name width function)
28  "Returns a modeline-field object."
29  (unless (or (eq width nil) (and (integerp width) (plusp width)))
30    (error "Width must be nil or a positive integer."))
31  (when (gethash name *modeline-field-names*)
32    (with-simple-restart (continue
33                          "Use the new definition for this modeline field.")
34      (error "Modeline field ~S already exists."
35             (gethash name *modeline-field-names*))))
36  (setf (gethash name *modeline-field-names*)
37        (%make-modeline-field name function width)))
38
39(defun modeline-field (name)
40  "Returns the modeline-field object named name.  If none exists, return nil."
41  (gethash name *modeline-field-names*))
42
43
44(declaim (inline modeline-field-name modeline-field-width modeline-field-function))
45
46(defun modeline-field-name (ml-field)
47  "Returns the name of a modeline field object."
48  (modeline-field-%name ml-field))
49
50(defun %set-modeline-field-name (ml-field name)
51  (check-type ml-field modeline-field)
52  (when (gethash name *modeline-field-names*)
53    (error "Modeline field ~S already exists."
54           (gethash name *modeline-field-names*)))
55  (remhash (modeline-field-%name ml-field) *modeline-field-names*)
56  (setf (modeline-field-%name ml-field) name)
57  (setf (gethash name *modeline-field-names*) ml-field))
58
59(defun modeline-field-width (ml-field)
60  "Returns the width of a modeline field."
61  (modeline-field-%width ml-field))
62
63(declaim (special *buffer-list*))
64
65(defun modeline-field-function (ml-field)
66  "Returns the function of a modeline field object.  It returns a string."
67  (modeline-field-%function ml-field))
68
69
70;;;; Default modeline and update hooks.
71
72(make-modeline-field :name :hemlock-literal :width 8
73                     :function #'(lambda (buffer)
74                                   "Returns \"Hemlock \"."
75                                   (declare (ignore buffer))
76                                   "Hemlock "))
77
78(make-modeline-field
79 :name :external-format
80 :function #'(lambda (buffer)
81               "Returns an indication of buffer's external-format, iff it's
82other than :DEFAULT"
83               (let* ((line-termination-string
84                       (case (buffer-line-termination buffer)
85                         ((:lf nil))
86                         ((:cr) "CR")
87                         ((:crlf) "CRLF")))
88                      (encoding-name (or (buffer-encoding-name buffer)
89                                         "Default")))
90                 (format nil "[~a~@[ ~a~]] "
91                         encoding-name line-termination-string))))
92
93
94(make-modeline-field
95 :name :package
96 :function #'(lambda (buffer)
97               "Returns the value of buffer's \"Current Package\" followed
98                by a colon and two spaces, or a string with one space."
99               (if (hemlock-bound-p 'hemlock::current-package :buffer buffer)
100                   (let ((val (variable-value 'hemlock::current-package
101                                              :buffer buffer)))
102                     (if (stringp val)
103                       (if (find-package val)
104                         (format nil "~A:  " val)
105                         (format nil "?~A?:  " val))
106                       " "))
107                   " ")))
108
109(make-modeline-field
110 :name :modes
111 :function #'(lambda (buffer)
112               "Returns buffer's modes followed by one space."
113               (let* ((m ()))
114                 (dolist (mode (buffer-minor-mode-objects buffer))
115                   (unless (mode-object-hidden mode)
116                     (push (mode-object-name mode) m)))
117                 (format nil "~A  " (cons (buffer-major-mode buffer)
118                                          (nreverse m))))))
119
120(make-modeline-field
121 :name :modifiedp
122 :function #'(lambda (buffer)
123               "Returns \"* \" if buffer is modified, or \"  \"."
124               (let ((modifiedp (buffer-document-modified buffer)))
125                 (if modifiedp
126                     "* "
127                     "  "))))
128
129(make-modeline-field
130 :name :buffer-name
131 :function #'(lambda (buffer)
132               "Returns buffer's name followed by a colon and a space if the
133                name is not derived from the buffer's pathname, or the empty
134                string."
135               (let ((pn (buffer-pathname buffer))
136                     (name (buffer-name buffer)))
137                 (cond ((not pn)
138                        (format nil "~A: " name))
139                       ((string/= (hemlock::pathname-to-buffer-name pn) name)
140                        (format nil "~A: " name))
141                       (t "")))))
142
143(make-modeline-field
144 :name :completion :width 40
145 :function #'(lambda (buffer)
146               (declare (special hemlock::*completion-mode-possibility*))
147               (declare (ignore buffer))
148               hemlock::*completion-mode-possibility*))
149
150
151
152
153;;; MAXIMUM-MODELINE-PATHNAME-LENGTH-HOOK is called whenever "Maximum Modeline
154;;; Pathname Length" is set.
155;;;
156(defun maximum-modeline-pathname-length-hook (name kind where new-value)
157  (declare (ignore name new-value))
158  (if (eq kind :buffer)
159    (note-modeline-change where)
160    (dolist (buffer *buffer-list*)
161      (when (buffer-modeline-field-p buffer :buffer-pathname)
162        (note-modeline-change buffer)))))
163
164(defun buffer-pathname-ml-field-fun (buffer)
165  "Returns the namestring of buffer's pathname if there is one.  When
166   \"Maximum Modeline Pathname Length\" is set, and the namestring is too long,
167   return a truncated namestring chopping off leading directory specifications."
168  (let ((pn (buffer-pathname buffer)))
169    (if pn
170        (let* ((name (namestring pn))
171               (length (length name))
172               ;; Prefer a buffer local value over the global one.
173               ;; Because variables don't work right, blow off looking for
174               ;; a value in the buffer's modes.  In the future this will
175               ;; be able to get the "current" value as if buffer were current.
176               (max (if (hemlock-bound-p 'hemlock::maximum-modeline-pathname-length
177                                          :buffer buffer)
178                         (variable-value 'hemlock::maximum-modeline-pathname-length
179                                         :buffer buffer)
180                         (variable-value 'hemlock::maximum-modeline-pathname-length
181                                         :global))))
182          (declare (simple-string name))
183          (if (or (not max) (<= length max))
184              name
185              (let* ((extra-chars (+ (- length max) 3))
186                     (slash (or (position #\/ name :start extra-chars)
187                                ;; If no slash, then file-namestring is very
188                                ;; long, and we should include all of it:
189                                (position #\/ name :from-end t
190                                          :end extra-chars))))
191                (if slash
192                    (concatenate 'simple-string "..." (subseq name slash))
193                    name))))
194        "")))
195
196
197
198(make-modeline-field
199 :name :buffer-pathname
200 :function 'buffer-pathname-ml-field-fun)
201
202
203
204(make-modeline-field
205 :name :process-info
206 :function #'(lambda (buffer)
207               (hemlock-ext:buffer-process-description buffer)))
208
209(defparameter *default-modeline-fields*
210  (list (modeline-field :modifiedp) ;(modeline-field :hemlock-literal)
211        (modeline-field :external-format)
212        (modeline-field :package)
213        (modeline-field :modes))
214  "This is the default value for \"Default Modeline Fields\".")
215
216(defun %init-mode-redisplay ()
217  (add-hook hemlock::buffer-major-mode-hook 'note-modeline-change)
218  (add-hook hemlock::buffer-minor-mode-hook 'note-modeline-change)
219  (add-hook hemlock::buffer-name-hook 'note-modeline-change)
220  (add-hook hemlock::buffer-pathname-hook 'note-modeline-change)
221  ;; (SETF (BUFFER-MODIFIED ...)) handles updating the modeline;
222  ;; it only wants to do so if the buffer's modified state changes.
223;  (add-hook hemlock::buffer-modified-hook 'note-modeline-change)
224)
225
226(defun note-modeline-change (buffer &rest more)
227  (declare (ignore more)) ;; used as hooks some of which pass more info
228  (hemlock-ext:invalidate-modeline buffer))
229
230;; Public version
231(defun update-modeline-fields (buffer)
232  (note-modeline-change buffer))
Note: See TracBrowser for help on using the repository browser.