/[cmucl]/src/hemlock/scribe.lisp
ViewVC logotype

Contents of /src/hemlock/scribe.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.5 - (show annotations)
Fri Jun 19 13:27:30 2009 UTC (4 years, 10 months ago) by rtoy
Branch: MAIN
CVS Tags: sparc-tramp-assem-base, post-merge-intl-branch, intl-branch-working-2010-02-19-1000, unicode-string-buffer-impl-base, release-20b-pre1, release-20b-pre2, unicode-string-buffer-base, sparc-tramp-assem-2010-07-19, amd64-dd-start, intl-2-branch-base, GIT-CONVERSION, cross-sol-x86-merged, intl-branch-working-2010-02-11-1000, RELEASE_20b, release-20a-base, cross-sol-x86-base, snapshot-2010-12, snapshot-2010-11, snapshot-2011-09, snapshot-2011-06, snapshot-2011-07, snapshot-2011-04, snapshot-2011-02, snapshot-2011-03, snapshot-2011-01, pre-merge-intl-branch, snapshot-2010-05, snapshot-2010-04, snapshot-2010-07, snapshot-2010-06, snapshot-2010-01, snapshot-2010-03, snapshot-2010-02, snapshot-2010-08, cross-sol-x86-2010-12-20, intl-branch-2010-03-18-1300, RELEASE_20a, release-20a-pre1, snapshot-2009-11, snapshot-2009-12, cross-sparc-branch-base, intl-branch-base, snapshot-2009-08, snapshot-2009-07, HEAD
Branch point for: cross-sparc-branch, RELEASE-20B-BRANCH, unicode-string-buffer-branch, sparc-tramp-assem-branch, RELEASE-20A-BRANCH, amd64-dd-branch, unicode-string-buffer-impl-branch, intl-branch, cross-sol-x86-branch, intl-2-branch
Changes since 1.4: +2 -2 lines
Change all references to char-code-limit to 256 when compiling on a
Unicode build.  This allows Hemlock to load and run but does not work
correctly with a Unicode build.  The display is wrong, among other
things.
1 ;;; -*- Log: hemlock.log; Package: Hemlock -*-
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 (ext:file-comment
8 "$Header: /tiger/var/lib/cvsroots/cmucl/src/hemlock/scribe.lisp,v 1.5 2009/06/19 13:27:30 rtoy Rel $")
9 ;;;
10 ;;; **********************************************************************
11 ;;;
12
13 (in-package "HEMLOCK")
14
15
16
17 ;;;; Variables.
18
19 (defvar *scribe-para-break-table* (make-hash-table :test #'equal)
20 "A table of the Scribe commands that should be paragraph delimiters.")
21 ;;;
22 (dolist (todo '("begin" "newpage" "make" "device" "caption" "tag" "end"
23 "chapter" "section" "appendix" "subsection" "paragraph"
24 "unnumbered" "appendixsection" "prefacesection" "heading"
25 "majorheading" "subheading"))
26 (setf (gethash todo *scribe-para-break-table*) t))
27
28 (defhvar "Open Paren Character"
29 "The open bracket inserted by Scribe commands."
30 :value #\[)
31
32 (defhvar "Close Paren Character"
33 "The close bracket inserted by Scribe commands."
34 :value #\])
35
36 (defhvar "Escape Character"
37 "The escape character inserted by Scribe commands."
38 :value #\@)
39
40 (defhvar "Scribe Bracket Table"
41 "This table maps a Scribe brackets, open and close, to their opposing
42 brackets."
43 :value (make-array #-unicode char-code-limit #+unicode 256))
44 ;;;
45 (mapc #'(lambda (x y)
46 (setf (svref (value scribe-bracket-table) (char-code x)) y)
47 (setf (svref (value scribe-bracket-table) (char-code y)) x))
48 '(#\( #\[ #\{ #\<) '(#\) #\] #\} #\>))
49 ;;;
50 (eval-when (compile eval)
51 (defmacro opposing-bracket (bracket)
52 `(svref (value scribe-bracket-table) (char-code ,bracket)))
53 ) ;eval-when
54
55
56
57 ;;;; "Scribe Syntax" Attribute.
58
59 (defattribute "Scribe Syntax"
60 "For Scribe Syntax, Possible types are:
61 :ESCAPE ; basically #\@.
62 :OPEN-PAREN ; Characters that open a Scribe paren: #\[, #\{, #\(, #\<.
63 :CLOSE-PAREN ; Characters that close a Scribe paren: #\], #\}, #\), #\>.
64 :SPACE ; Delimits end of a Scribe command.
65 :NEWLINE ; Delimits end of a Scribe command."
66 'symbol nil)
67
68 (setf (character-attribute :SCRIBE-SYNTAX #\)) :CLOSE-PAREN)
69 (setf (character-attribute :SCRIBE-SYNTAX #\]) :CLOSE-PAREN)
70 (setf (character-attribute :SCRIBE-SYNTAX #\}) :CLOSE-PAREN)
71 (setf (character-attribute :SCRIBE-SYNTAX #\>) :CLOSE-PAREN)
72
73 (setf (character-attribute :SCRIBE-SYNTAX #\() :OPEN-PAREN)
74 (setf (character-attribute :SCRIBE-SYNTAX #\[) :OPEN-PAREN)
75 (setf (character-attribute :SCRIBE-SYNTAX #\{) :OPEN-PAREN)
76 (setf (character-attribute :SCRIBE-SYNTAX #\<) :OPEN-PAREN)
77
78 (setf (character-attribute :SCRIBE-SYNTAX #\Space) :SPACE)
79 (setf (character-attribute :SCRIBE-SYNTAX #\Newline) :NEWLINE)
80 (setf (character-attribute :SCRIBE-SYNTAX #\@) :ESCAPE)
81
82
83
84 ;;;; "Scribe" mode and setup.
85
86 (defmode "Scribe" :major-p t)
87
88 (shadow-attribute :paragraph-delimiter #\@ 1 "Scribe")
89 (shadow-attribute :word-delimiter #\' 0 "Scribe") ;from Text Mode
90 (shadow-attribute :word-delimiter #\backspace 0 "Scribe") ;from Text Mode
91 (shadow-attribute :word-delimiter #\_ 0 "Scribe") ;from Text Mode
92
93 (define-file-type-hook ("mss") (buffer type)
94 (declare (ignore type))
95 (setf (buffer-major-mode buffer) "Scribe"))
96
97
98
99 ;;;; Commands.
100
101 (defcommand "Scribe Mode" (p)
102 "Puts buffer in Scribe mode. Sets up comment variables and has delimiter
103 matching. The definition of paragraphs is changed to know about scribe
104 commands."
105 "Puts buffer in Scribe mode."
106 (declare (ignore p))
107 (setf (buffer-major-mode (current-buffer)) "Scribe"))
108
109 (defcommand "Select Scribe Warnings" (p)
110 "Goes to the Scribe Warnings buffer if it exists."
111 "Goes to the Scribe Warnings buffer if it exists."
112 (declare (ignore p))
113 (let ((buffer (getstring "Scribe Warnings" *buffer-names*)))
114 (if buffer
115 (change-to-buffer buffer)
116 (editor-error "There is no Scribe Warnings buffer."))))
117
118 (defcommand "Add Scribe Paragraph Delimiter"
119 (p &optional
120 (word (prompt-for-string
121 :prompt "Scribe command: "
122 :help "Name of Scribe command to make delimit paragraphs."
123 :trim t)))
124 "Prompts for a name to add to the table of commands that delimit paragraphs
125 in Scribe mode. If a prefix argument is supplied, then the command name is
126 removed from the table."
127 "Add or remove Word in the *scribe-para-break-table*, depending on P."
128 (setf (gethash word *scribe-para-break-table*) (not p)))
129
130 (defcommand "List Scribe Paragraph Delimiters" (p)
131 "Pops up a display of the Scribe commands that delimit paragraphs."
132 "Pops up a display of the Scribe commands that delimit paragraphs."
133 (declare (ignore p))
134 (let (result)
135 (maphash #'(lambda (k v)
136 (declare (ignore v))
137 (push k result))
138 *scribe-para-break-table*)
139 (setf result (sort result #'string<))
140 (with-pop-up-display (s :height (length result))
141 (dolist (ele result) (write-line ele s)))))
142
143 (defcommand "Scribe Insert Bracket" (p)
144 "Inserts a the bracket it is bound to and then shows the matching bracket."
145 "Inserts a the bracket it is bound to and then shows the matching bracket."
146 (declare (ignore p))
147 (scribe-insert-paren (current-point)
148 (ext:key-event-char *last-key-event-typed*)))
149
150
151 (defhvar "Scribe Command Table"
152 "This is a character dispatching table indicating which Scribe command or
153 environment to use."
154 :value (make-hash-table)
155 :mode "Scribe")
156
157 (defvar *scribe-directive-type-table*
158 (make-string-table :initial-contents
159 '(("Command" . :command)
160 ("Environment" . :environment))))
161
162 (defcommand "Add Scribe Directive" (p &optional
163 (command-name nil command-name-p)
164 type key-event mode)
165 "Adds a new scribe function to put into \"Scribe Command Table\"."
166 "Adds a new scribe function to put into \"Scribe Command Table\"."
167 (declare (ignore p))
168 (let ((command-name (if command-name-p
169 command-name
170 (or command-name
171 (prompt-for-string :help "Directive Name"
172 :prompt "Directive: ")))))
173 (multiple-value-bind (ignore type)
174 (if type
175 (values nil type)
176 (prompt-for-keyword
177 (list *scribe-directive-type-table*)
178 :help "Enter Command or Environment."
179 :prompt "Command or Environment: "))
180 (declare (ignore ignore))
181 (let ((key-event (or key-event
182 (prompt-for-key-event :prompt
183 "Dispatch Character: "))))
184 (setf (gethash key-event
185 (cond (mode
186 (variable-value 'scribe-command-table :mode mode))
187 ((hemlock-bound-p 'scribe-command-table)
188 (value scribe-command-table))
189 (t (editor-error
190 "Could not find \"Scribe Command Table\"."))))
191 (cons type command-name))))))
192
193 (defcommand "Insert Scribe Directive" (p)
194 "Prompts for a character to dispatch on. Some indicate \"commands\" versus
195 \"environments\". Commands are wrapped around the previous or current word.
196 If there is no previous word, the command is insert, leaving point between
197 the brackets. Environments are wrapped around the next or current
198 paragraph, but when the region is active, this wraps the environment around
199 the region. Each uses \"Open Paren Character\" and \"Close Paren
200 Character\"."
201 "Wrap some text with some stuff."
202 (declare (ignore p))
203 (loop
204 (let ((key-event (prompt-for-key-event :prompt "Dispatch Character: ")))
205 (if (logical-key-event-p key-event :help)
206 (directive-help)
207 (let ((table-entry (gethash key-event (value scribe-command-table))))
208 (ecase (car table-entry)
209 (:command
210 (insert-scribe-directive (current-point) (cdr table-entry))
211 (return))
212 (:environment
213 (enclose-with-environment (current-point) (cdr table-entry))
214 (return))
215 ((nil) (editor-error "Unknown dispatch character."))))))))
216
217
218
219 ;;;; "Insert Scribe Directive" support.
220
221 (defun directive-help ()
222 (let ((commands ())
223 (environments ()))
224 (declare (list commands environments))
225 (maphash #'(lambda (k v)
226 (if (eql (car v) :command)
227 (push (cons k (cdr v)) commands)
228 (push (cons k (cdr v)) environments)))
229 (value scribe-command-table))
230 (setf commands (sort commands #'string< :key #'cdr))
231 (setf environments (sort environments #'string< :key #'cdr))
232 (with-pop-up-display (s :height (1+ (max (length commands)
233 (length environments))))
234 (format s "~2TCommands~47TEnvironments~%")
235 (do ((commands commands (rest commands))
236 (environments environments (rest environments)))
237 ((and (endp commands) (endp environments)))
238 (let* ((command (first commands))
239 (environment (first environments))
240 (cmd-char (first command))
241 (cmd-name (rest command))
242 (env-char (first environment))
243 (env-name (rest environment)))
244 (write-string " " s)
245 (when cmd-char
246 (ext:print-pretty-key-event cmd-char s)
247 (format s "~7T")
248 (write-string (or cmd-name "<prompts for command name>") s))
249 (when env-char
250 (format s "~47T")
251 (ext:print-pretty-key-event env-char s)
252 (format s "~51T")
253 (write-string (or env-name "<prompts for command name>") s))
254 (terpri s))))))
255
256 ;;;
257 ;;; Inserting and extending :command directives.
258 ;;;
259
260 (defhvar "Insert Scribe Directive Function"
261 "\"Insert Scribe Directive\" calls this function when the directive type
262 is :command. The function takes four arguments: a mark pointing to the word
263 start, the formatting command string, the open-paren character to use, and a
264 mark pointing to the word end."
265 :value 'scribe-insert-scribe-directive-fun
266 :mode "Scribe")
267
268 (defun scribe-insert-scribe-directive-fun (word-start command-string
269 open-paren-char word-end)
270 (insert-character word-start (value escape-character))
271 (insert-string word-start command-string)
272 (insert-character word-start open-paren-char)
273 (insert-character word-end (value close-paren-character)))
274
275 (defhvar "Extend Scribe Directive Function"
276 "\"Insert Scribe Directive\" calls this function when the directive type is
277 :command to extend the the commands effect. This function takes a string
278 and three marks: the first on pointing before the open-paren character for
279 the directive. The string is the command-string to selected by the user
280 which this function uses to determine if it is actually extending a command
281 or inserting a new one. The function must move the first mark before any
282 command text for the directive and the second mark to the end of any command
283 text. It moves the third mark to the previous word's start where the
284 command region should be. If this returns non-nil \"Insert Scribe
285 Directive\" moves the command region previous one word, and otherwise it
286 inserts the directive."
287 :value 'scribe-extend-scribe-directive-fun
288 :mode "Scribe")
289
290 (defun scribe-extend-scribe-directive-fun (command-string
291 command-end command-start word-start)
292 (word-offset (move-mark command-start command-end) -1)
293 (when (string= (the simple-string (region-to-string
294 (region command-start command-end)))
295 command-string)
296 (mark-before command-start)
297 (mark-after command-end)
298 (word-offset (move-mark word-start command-start) -1)))
299
300 ;;; INSERT-SCRIBE-DIRECTIVE first looks for the current or previous word at
301 ;;; mark. Word-p says if we found one. If mark is immediately before a word,
302 ;;; we use that word instead of the previous. This is because if mark
303 ;;; corresponds to the CURRENT-POINT, the Hemlock cursor is displayed on the
304 ;;; first character of the word making users think the mark is in the word
305 ;;; instead of before it. If we find a word, then we see if it already has
306 ;;; the given command-string, and if it does, we extend the use of the command-
307 ;;; string to the previous word. At the end, if we hadn't found a word, we
308 ;;; backup the mark one character to put it between the command brackets.
309 ;;;
310 (defun insert-scribe-directive (mark &optional command-string)
311 (with-mark ((word-start mark :left-inserting)
312 (word-end mark :left-inserting))
313 (let ((open-paren-char (value open-paren-character))
314 (word-p (if (and (zerop (character-attribute
315 :word-delimiter
316 (next-character word-start)))
317 (= (character-attribute
318 :word-delimiter
319 (previous-character word-start))
320 1))
321 word-start
322 (word-offset word-start -1)))
323 (command-string (or command-string
324 (prompt-for-string
325 :trim t :prompt "Environment: "
326 :help "Name of environment to enclose with."))))
327 (declare (simple-string command-string))
328 (cond
329 (word-p
330 (word-offset (move-mark word-end word-start) 1)
331 (if (test-char (next-character word-end) :scribe-syntax
332 :close-paren)
333 (with-mark ((command-start word-start :left-inserting)
334 (command-end word-end :left-inserting))
335 ;; Move command-end from word-end to open-paren of command.
336 (balance-paren (mark-after command-end))
337 (if (funcall (value extend-scribe-directive-function)
338 command-string command-end command-start word-start)
339 (let ((region (delete-and-save-region
340 (region command-start command-end))))
341 (word-offset (move-mark word-start command-start) -1)
342 (ninsert-region word-start region))
343 (funcall (value insert-scribe-directive-function)
344 word-start command-string open-paren-char
345 word-end)))
346 (funcall (value insert-scribe-directive-function)
347 word-start command-string open-paren-char word-end)))
348 (t
349 (funcall (value insert-scribe-directive-function)
350 word-start command-string open-paren-char word-end)
351 (mark-before mark))))))
352
353 ;;;
354 ;;; Inserting :environment directives.
355 ;;;
356
357 (defun enclose-with-environment (mark &optional environment)
358 (if (region-active-p)
359 (let ((region (current-region)))
360 (with-mark ((top (region-start region) :left-inserting)
361 (bottom (region-end region) :left-inserting))
362 (get-and-insert-environment top bottom environment)))
363 (with-mark ((bottom-mark mark :left-inserting))
364 (let ((paragraphp (paragraph-offset bottom-mark 1)))
365 (unless (or paragraphp
366 (and (last-line-p bottom-mark)
367 (end-line-p bottom-mark)
368 (not (blank-line-p (mark-line bottom-mark)))))
369 (editor-error "No paragraph to enclose."))
370 (with-mark ((top-mark bottom-mark :left-inserting))
371 (paragraph-offset top-mark -1)
372 (cond ((not (blank-line-p (mark-line top-mark)))
373 (insert-character top-mark #\Newline)
374 (mark-before top-mark))
375 (t
376 (insert-character top-mark #\Newline)))
377 (cond ((and (last-line-p bottom-mark)
378 (not (blank-line-p (mark-line bottom-mark))))
379 (insert-character bottom-mark #\Newline))
380 (t
381 (insert-character bottom-mark #\Newline)
382 (mark-before bottom-mark)))
383 (get-and-insert-environment top-mark bottom-mark environment))))))
384
385 (defun get-and-insert-environment (top-mark bottom-mark environment)
386 (let ((environment (or environment
387 (prompt-for-string
388 :trim t :prompt "Environment: "
389 :help "Name of environment to enclose with."))))
390 (insert-environment top-mark "begin" environment)
391 (insert-environment bottom-mark "end" environment)))
392
393 (defun insert-environment (mark command environment)
394 (let ((esc-char (value escape-character))
395 (open-paren (value open-paren-character))
396 (close-paren (value close-paren-character)))
397 (insert-character mark esc-char)
398 (insert-string mark command)
399 (insert-character mark open-paren)
400 (insert-string mark environment)
401 (insert-character mark close-paren)))
402
403
404 (add-scribe-directive-command nil nil :Environment #k"Control-l" "Scribe")
405 (add-scribe-directive-command nil nil :Command #k"Control-w" "Scribe")
406 (add-scribe-directive-command nil "Begin" :Command #k"b" "Scribe")
407 (add-scribe-directive-command nil "End" :Command #k"e" "Scribe")
408 (add-scribe-directive-command nil "Center" :Environment #k"c" "Scribe")
409 (add-scribe-directive-command nil "Description" :Environment #k"d" "Scribe")
410 (add-scribe-directive-command nil "Display" :Environment #k"Control-d" "Scribe")
411 (add-scribe-directive-command nil "Enumerate" :Environment #k"n" "Scribe")
412 (add-scribe-directive-command nil "Example" :Environment #k"x" "Scribe")
413 (add-scribe-directive-command nil "FileExample" :Environment #k"y" "Scribe")
414 (add-scribe-directive-command nil "FlushLeft" :Environment #k"l" "Scribe")
415 (add-scribe-directive-command nil "FlushRight" :Environment #k"r" "Scribe")
416 (add-scribe-directive-command nil "Format" :Environment #k"f" "Scribe")
417 (add-scribe-directive-command nil "Group" :Environment #k"g" "Scribe")
418 (add-scribe-directive-command nil "Itemize" :Environment #k"Control-i" "Scribe")
419 (add-scribe-directive-command nil "Multiple" :Environment #k"m" "Scribe")
420 (add-scribe-directive-command nil "ProgramExample" :Environment #k"p" "Scribe")
421 (add-scribe-directive-command nil "Quotation" :Environment #k"q" "Scribe")
422 (add-scribe-directive-command nil "Text" :Environment #k"t" "Scribe")
423 (add-scribe-directive-command nil "i" :Command #k"i" "Scribe")
424 (add-scribe-directive-command nil "b" :Command #k"Control-b" "Scribe")
425 (add-scribe-directive-command nil "-" :Command #k"\-" "Scribe")
426 (add-scribe-directive-command nil "+" :Command #k"+" "Scribe")
427 (add-scribe-directive-command nil "u" :Command #k"Control-j" "Scribe")
428 (add-scribe-directive-command nil "p" :Command #k"Control-p" "Scribe")
429 (add-scribe-directive-command nil "r" :Command #k"Control-r" "Scribe")
430 (add-scribe-directive-command nil "t" :Command #k"Control-t" "Scribe")
431 (add-scribe-directive-command nil "g" :Command #k"Control-a" "Scribe")
432 (add-scribe-directive-command nil "un" :Command #k"Control-n" "Scribe")
433 (add-scribe-directive-command nil "ux" :Command #k"Control-x" "Scribe")
434 (add-scribe-directive-command nil "c" :Command #k"Control-k" "Scribe")
435
436
437
438 ;;;; Scribe paragraph delimiter function.
439
440 (defhvar "Paragraph Delimiter Function"
441 "Scribe Mode's way of delimiting paragraphs."
442 :mode "Scribe"
443 :value 'scribe-delim-para-function)
444
445 (defun scribe-delim-para-function (mark)
446 "Returns whether there is a paragraph delimiting Scribe command on the
447 current line. Add or remove commands for this purpose with the command
448 \"Add Scribe Paragraph Delimiter\"."
449 (let ((next-char (next-character mark)))
450 (when (paragraph-delimiter-attribute-p next-char)
451 (if (eq (character-attribute :scribe-syntax next-char) :escape)
452 (with-mark ((begin mark)
453 (end mark))
454 (mark-after begin)
455 (if (scan-char end :scribe-syntax (or :space :newline :open-paren))
456 (gethash (nstring-downcase (region-to-string (region begin end)))
457 *scribe-para-break-table*)
458 (editor-error "Unable to find Scribe command ending.")))
459 t))))
460
461
462
463 ;;;; Bracket matching.
464
465 (defun scribe-insert-paren (mark bracket-char)
466 (insert-character mark bracket-char)
467 (with-mark ((m mark))
468 (if (balance-paren m)
469 (when (value paren-pause-period)
470 (unless (show-mark m (current-window) (value paren-pause-period))
471 (clear-echo-area)
472 (message "~A" (line-string (mark-line m)))))
473 (editor-error))))
474
475 ;;; BALANCE-PAREN moves the mark to the matching open paren character, or
476 ;;; returns nil. The mark must be after the closing paren.
477 ;;;
478 (defun balance-paren (mark)
479 (with-mark ((m mark))
480 (when (rev-scan-char m :scribe-syntax (or :open-paren :close-paren))
481 (mark-before m)
482 (let ((paren-count 1)
483 (first-paren (next-character m)))
484 (loop
485 (unless (rev-scan-char m :scribe-syntax (or :open-paren :close-paren))
486 (return nil))
487 (if (test-char (previous-character m) :scribe-syntax :open-paren)
488 (setq paren-count (1- paren-count))
489 (setq paren-count (1+ paren-count)))
490 (when (< paren-count 0) (return nil))
491 (when (= paren-count 0)
492 ;; OPPOSING-BRACKET calls VALUE (each time around the loop)
493 (cond ((char= (opposing-bracket (previous-character m)) first-paren)
494 (mark-before (move-mark mark m))
495 (return t))
496 (t (editor-error "Scribe paren mismatch."))))
497 (mark-before m))))))

  ViewVC Help
Powered by ViewVC 1.1.5