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

Contents of /src/hemlock/scribe.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.5 - (hide annotations)
Fri Jun 19 13:27:30 2009 UTC (4 years, 9 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 ram 1.1 ;;; -*- Log: hemlock.log; Package: Hemlock -*-
2     ;;;
3     ;;; **********************************************************************
4 ram 1.3 ;;; 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 rtoy 1.5 "$Header: /tiger/var/lib/cvsroots/cmucl/src/hemlock/scribe.lisp,v 1.5 2009/06/19 13:27:30 rtoy Rel $")
9 ram 1.3 ;;;
10 ram 1.1 ;;; **********************************************************************
11     ;;;
12    
13 ram 1.2 (in-package "HEMLOCK")
14 ram 1.1
15 ram 1.2
16 ram 1.1
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 rtoy 1.5 :value (make-array #-unicode char-code-limit #+unicode 256))
44 ram 1.1 ;;;
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 ram 1.2 :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 ram 1.1 '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 ram 1.2 (scribe-insert-paren (current-point)
148     (ext:key-event-char *last-key-event-typed*)))
149 ram 1.1
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 ram 1.2 type key-event mode)
165 ram 1.1 "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 ram 1.2 (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 ram 1.1 (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 ram 1.2 (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 ram 1.1
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 ram 1.2 (value scribe-command-table))
230     (setf commands (sort commands #'string< :key #'cdr))
231     (setf environments (sort environments #'string< :key #'cdr))
232 ram 1.1 (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 ram 1.2 (ext:print-pretty-key-event cmd-char s)
247 ram 1.1 (format s "~7T")
248     (write-string (or cmd-name "<prompts for command name>") s))
249     (when env-char
250     (format s "~47T")
251 ram 1.2 (ext:print-pretty-key-event env-char s)
252 ram 1.1 (format s "~51T")
253     (write-string (or env-name "<prompts for command name>") s))
254     (terpri s))))))
255    
256 ram 1.2 ;;;
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 ram 1.1 ;;; 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 ram 1.2 (cond
329     (word-p
330 ram 1.1 (word-offset (move-mark word-end word-start) 1)
331 ram 1.2 (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 ram 1.1
353 ram 1.2 ;;;
354     ;;; Inserting :environment directives.
355     ;;;
356    
357 ram 1.1 (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 ram 1.2 (insert-environment top-mark "begin" environment)
391     (insert-environment bottom-mark "end" environment)))
392 ram 1.1
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 ram 1.2 (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 ram 1.1
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