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

Last change on this file since 12859 was 12859, checked in by gz, 10 years ago

Make sure that all hemlock functions defined outside of hemlock are in the hemlock-ext package, to make it easier to keep track of them

  • 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 (hemlock-ext: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-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.