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

Contents of /src/hemlock/scribe.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.1 - (show annotations)
Wed May 9 13:05:47 1990 UTC (23 years, 11 months ago) by ram
Branch: MAIN
Initial revision
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