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

Contents of /src/hemlock/scribe.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5