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

Contents of /src/hemlock/scribe.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5