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

Diff of /src/hemlock/scribe.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.1 by ram, Wed May 9 13:05:47 1990 UTC revision 1.2 by ram, Fri Jul 13 15:14:22 1990 UTC
# Line 8  Line 8 
8  ;;; Scott Fahlman (FAHLMAN@CMUC).  ;;; Scott Fahlman (FAHLMAN@CMUC).
9  ;;; **********************************************************************  ;;; **********************************************************************
10  ;;;  ;;;
11  (in-package 'hemlock)  
12    (in-package "HEMLOCK")
13    
14    
15    
# Line 56  Line 57 
57    
58  (defattribute "Scribe Syntax"  (defattribute "Scribe Syntax"
59    "For Scribe Syntax, Possible types are:    "For Scribe Syntax, Possible types are:
60    :ESCAPE           ; basically #\@.     :ESCAPE           ; basically #\@.
61    :OPEN-PAREN       ; Characters that open a Scribe paren:  #\[, #\{, #\(, #\<.     :OPEN-PAREN       ; Characters that open a Scribe paren:  #\[, #\{, #\(, #\<.
62    :CLOSE-PAREN      ; Characters that close a Scribe paren:  #\], #\}, #\), #\>.     :CLOSE-PAREN      ; Characters that close a Scribe paren:  #\], #\}, #\), #\>.
63    :SPACE            ; Delimits end of a Scribe command.     :SPACE            ; Delimits end of a Scribe command.
64    :NEWLINE          ; Delimits end of a Scribe command."     :NEWLINE          ; Delimits end of a Scribe command."
65    'symbol nil)    'symbol nil)
66    
67  (setf (character-attribute :SCRIBE-SYNTAX #\)) :CLOSE-PAREN)  (setf (character-attribute :SCRIBE-SYNTAX #\)) :CLOSE-PAREN)
# Line 142  Line 143 
143    "Inserts a the bracket it is bound to and then shows the matching bracket."    "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."    "Inserts a the bracket it is bound to and then shows the matching bracket."
145    (declare (ignore p))    (declare (ignore p))
146    (scribe-insert-paren (current-point) *last-character-typed*))    (scribe-insert-paren (current-point)
147                           (ext:key-event-char *last-key-event-typed*)))
148    
149    
150  (defhvar "Scribe Command Table"  (defhvar "Scribe Command Table"
# Line 158  Line 160 
160    
161  (defcommand "Add Scribe Directive" (p &optional  (defcommand "Add Scribe Directive" (p &optional
162                                        (command-name nil command-name-p)                                        (command-name nil command-name-p)
163                                        type key (mode "Scribe"))                                        type key-event mode)
164    "Adds a new scribe function to put into \"Scribe Command Table\"."    "Adds a new scribe function to put into \"Scribe Command Table\"."
165    "Adds a new scribe function to put into \"Scribe Command Table\"."    "Adds a new scribe function to put into \"Scribe Command Table\"."
166    (declare (ignore p))    (declare (ignore p))
# Line 175  Line 177 
177                                :help "Enter Command or Environment."                                :help "Enter Command or Environment."
178                                :prompt "Command or Environment: "))                                :prompt "Command or Environment: "))
179        (declare (ignore ignore))        (declare (ignore ignore))
180        (let ((key (or key        (let ((key-event (or key-event
181                       (prompt-for-character :prompt "Dispatch Character: "))))                             (prompt-for-key-event :prompt
182          (setf (gethash key (variable-value 'scribe-command-table :mode mode))                                                   "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                (cons type command-name))))))                (cons type command-name))))))
191    
192  (defcommand "Insert Scribe Directive" (p)  (defcommand "Insert Scribe Directive" (p)
# Line 190  Line 199 
199     Character\"."     Character\"."
200    "Wrap some text with some stuff."    "Wrap some text with some stuff."
201    (declare (ignore p))    (declare (ignore p))
202    (command-case (:bind key :prompt "Dispatch Character: ")    (loop
203      (:help "help"      (let ((key-event (prompt-for-key-event :prompt "Dispatch Character: ")))
204             (directive-help)        (if (logical-key-event-p key-event :help)
205             (reprompt))            (directive-help)
206      (t (let ((table-entry (gethash key (value scribe-command-table))))            (let ((table-entry (gethash key-event (value scribe-command-table))))
207           (if (eq (car table-entry) :command)              (ecase (car table-entry)
208               (insert-scribe-directive (current-point) (cdr table-entry))                (:command
209               (enclose-with-environment (current-point) (cdr table-entry)))))))                 (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    
216    
217    
# Line 211  Line 225 
225                   (if (eql (car v) :command)                   (if (eql (car v) :command)
226                       (push (cons k (cdr v)) commands)                       (push (cons k (cdr v)) commands)
227                       (push (cons k (cdr v)) environments)))                       (push (cons k (cdr v)) environments)))
228               (variable-value 'Scribe-Command-Table :mode "Scribe"))               (value scribe-command-table))
229      (setq commands (sort commands #'string< :key #'cdr))      (setf commands (sort commands #'string< :key #'cdr))
230      (setq environments (sort environments #'string< :key #'cdr))      (setf environments (sort environments #'string< :key #'cdr))
231      (with-pop-up-display (s :height (1+ (max (length commands)      (with-pop-up-display (s :height (1+ (max (length commands)
232                                               (length environments))))                                               (length environments))))
233        (format s "~2TCommands~47TEnvironments~%")        (format s "~2TCommands~47TEnvironments~%")
# Line 228  Line 242 
242                 (env-name (rest environment)))                 (env-name (rest environment)))
243            (write-string "  " s)            (write-string "  " s)
244            (when cmd-char            (when cmd-char
245              (print-pretty-character cmd-char s)              (ext:print-pretty-key-event cmd-char s)
246              (format s "~7T")              (format s "~7T")
247              (write-string (or cmd-name "<prompts for command name>") s))              (write-string (or cmd-name "<prompts for command name>") s))
248            (when env-char            (when env-char
249              (format s "~47T")              (format s "~47T")
250              (print-pretty-character env-char s)              (ext:print-pretty-key-event env-char s)
251              (format s "~51T")              (format s "~51T")
252              (write-string (or env-name "<prompts for command name>") s))              (write-string (or env-name "<prompts for command name>") s))
253            (terpri s))))))            (terpri s))))))
254    
255    ;;;
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  ;;; INSERT-SCRIBE-DIRECTIVE first looks for the current or previous word at  ;;; 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,  ;;; 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  ;;; we use that word instead of the previous.  This is because if mark
# Line 266  Line 324 
324                                 :trim t :prompt "Environment: "                                 :trim t :prompt "Environment: "
325                                 :help "Name of environment to enclose with."))))                                 :help "Name of environment to enclose with."))))
326        (declare (simple-string command-string))        (declare (simple-string command-string))
327        (when word-p        (cond
328           (word-p
329          (word-offset (move-mark word-end word-start) 1)          (word-offset (move-mark word-end word-start) 1)
330          (when (test-char (next-character word-end) :scribe-syntax          (if (test-char (next-character word-end) :scribe-syntax
331                           :close-paren)                         :close-paren)
332            (with-mark ((command-start word-start)              (with-mark ((command-start word-start :left-inserting)
333                        (command-end word-end))                          (command-end word-end :left-inserting))
334              (balance-paren (mark-after command-end))                ;; Move command-end from word-end to open-paren of command.
335              (word-offset (move-mark command-start command-end) -1)                (balance-paren (mark-after command-end))
336              (when (string= (the simple-string                (if (funcall (value extend-scribe-directive-function)
337                                  (region-to-string (region command-start                             command-string command-end command-start word-start)
338                                                            command-end)))                    (let ((region (delete-and-save-region
339                             command-string)                                   (region command-start command-end))))
340                (mark-before command-start)                      (word-offset (move-mark word-start command-start) -1)
341                (mark-after command-end)                      (ninsert-region word-start region))
342                (setf open-paren-char                    (funcall (value insert-scribe-directive-function)
343                      (opposing-bracket (next-character word-end)))                             word-start command-string open-paren-char
344                (delete-region (region command-start command-end))                             word-end)))
345                (delete-characters word-end)              (funcall (value insert-scribe-directive-function)
346                (word-offset (move-mark word-start command-start) -1)))))                       word-start command-string open-paren-char word-end)))
347        (insert-character word-start (value escape-character))          (t
348        (insert-string word-start command-string)           (funcall (value insert-scribe-directive-function)
349        (insert-character word-start open-paren-char)                    word-start command-string open-paren-char word-end)
350        (insert-character word-end (value close-paren-character))           (mark-before mark))))))
351        (unless word-p (mark-before mark)))))  
352    ;;;
353    ;;; Inserting :environment directives.
354    ;;;
355    
356  (defun enclose-with-environment (mark &optional environment)  (defun enclose-with-environment (mark &optional environment)
357    (if (region-active-p)    (if (region-active-p)
# Line 324  Line 386 
386                           (prompt-for-string                           (prompt-for-string
387                            :trim t :prompt "Environment: "                            :trim t :prompt "Environment: "
388                            :help "Name of environment to enclose with."))))                            :help "Name of environment to enclose with."))))
389      (insert-environment top-mark "Begin" environment)      (insert-environment top-mark "begin" environment)
390      (insert-environment bottom-mark "End" environment)))      (insert-environment bottom-mark "end" environment)))
391    
392  (defun insert-environment (mark command environment)  (defun insert-environment (mark command environment)
393    (let ((esc-char (value escape-character))    (let ((esc-char (value escape-character))
# Line 338  Line 400 
400        (insert-character mark close-paren)))        (insert-character mark close-paren)))
401    
402    
403  (Add-Scribe-Directive-Command nil nil :Environment #\Control-\l)  (add-scribe-directive-command nil nil :Environment #k"Control-l" "Scribe")
404  (Add-Scribe-Directive-Command nil nil :Command #\Control-\w)  (add-scribe-directive-command nil nil :Command #k"Control-w" "Scribe")
405  (Add-Scribe-Directive-Command nil "Begin" :Command #\b)  (add-scribe-directive-command nil "Begin" :Command #k"b" "Scribe")
406  (Add-Scribe-Directive-Command nil "End" :Command #\e)  (add-scribe-directive-command nil "End" :Command #k"e" "Scribe")
407  (Add-Scribe-Directive-Command nil "Center" :Environment #\c)  (add-scribe-directive-command nil "Center" :Environment #k"c" "Scribe")
408  (Add-Scribe-Directive-Command nil "Description" :Environment #\d)  (add-scribe-directive-command nil "Description" :Environment #k"d" "Scribe")
409  (Add-Scribe-Directive-Command nil "Display" :Environment #\Control-\d)  (add-scribe-directive-command nil "Display" :Environment #k"Control-d" "Scribe")
410  (Add-Scribe-Directive-Command nil "Enumerate" :Environment #\n)  (add-scribe-directive-command nil "Enumerate" :Environment #k"n" "Scribe")
411  (Add-Scribe-Directive-Command nil "Example" :Environment #\x)  (add-scribe-directive-command nil "Example" :Environment #k"x" "Scribe")
412  (Add-Scribe-Directive-Command nil "FileExample" :Environment #\y)  (add-scribe-directive-command nil "FileExample" :Environment #k"y" "Scribe")
413  (Add-Scribe-Directive-Command nil "FlushLeft" :Environment #\l)  (add-scribe-directive-command nil "FlushLeft" :Environment #k"l" "Scribe")
414  (Add-Scribe-Directive-Command nil "FlushRight" :Environment #\r)  (add-scribe-directive-command nil "FlushRight" :Environment #k"r" "Scribe")
415  (Add-Scribe-Directive-Command nil "Format" :Environment #\f)  (add-scribe-directive-command nil "Format" :Environment #k"f" "Scribe")
416  (Add-Scribe-Directive-Command nil "Group" :Environment #\g)  (add-scribe-directive-command nil "Group" :Environment #k"g" "Scribe")
417  (Add-Scribe-Directive-Command nil "Itemize" :Environment #\Control-\i)  (add-scribe-directive-command nil "Itemize" :Environment #k"Control-i" "Scribe")
418  (Add-Scribe-Directive-Command nil "Multiple" :Environment #\m)  (add-scribe-directive-command nil "Multiple" :Environment #k"m" "Scribe")
419  (Add-Scribe-Directive-Command nil "ProgramExample" :Environment #\p)  (add-scribe-directive-command nil "ProgramExample" :Environment #k"p" "Scribe")
420  (Add-Scribe-Directive-Command nil "Quotation" :Environment #\q)  (add-scribe-directive-command nil "Quotation" :Environment #k"q" "Scribe")
421  (Add-Scribe-Directive-Command nil "Text" :Environment #\t)  (add-scribe-directive-command nil "Text" :Environment #k"t" "Scribe")
422  (Add-Scribe-Directive-Command nil "i" :Command #\i)  (add-scribe-directive-command nil "i" :Command #k"i" "Scribe")
423  (Add-Scribe-Directive-Command nil "b" :Command #\Control-\b)  (add-scribe-directive-command nil "b" :Command #k"Control-b" "Scribe")
424  (Add-Scribe-Directive-Command nil "-" :Command #\-)  (add-scribe-directive-command nil "-" :Command #k"\-" "Scribe")
425  (Add-Scribe-Directive-Command nil "+" :Command #\+)  (add-scribe-directive-command nil "+" :Command #k"+" "Scribe")
426  (Add-Scribe-Directive-Command nil "u" :Command #\Control-\j)  (add-scribe-directive-command nil "u" :Command #k"Control-j" "Scribe")
427  (Add-Scribe-Directive-Command nil "p" :Command #\Control-\p)  (add-scribe-directive-command nil "p" :Command #k"Control-p" "Scribe")
428  (Add-Scribe-Directive-Command nil "r" :Command #\Control-\r)  (add-scribe-directive-command nil "r" :Command #k"Control-r" "Scribe")
429  (Add-Scribe-Directive-Command nil "t" :Command #\Control-\t)  (add-scribe-directive-command nil "t" :Command #k"Control-t" "Scribe")
430  (Add-Scribe-Directive-Command nil "g" :Command #\Control-\a)  (add-scribe-directive-command nil "g" :Command #k"Control-a" "Scribe")
431  (Add-Scribe-Directive-Command nil "un" :Command #\Control-\n)  (add-scribe-directive-command nil "un" :Command #k"Control-n" "Scribe")
432  (Add-Scribe-Directive-Command nil "ux" :Command #\Control-\x)  (add-scribe-directive-command nil "ux" :Command #k"Control-x" "Scribe")
433  (Add-Scribe-Directive-Command nil "c" :Command #\Control-\k)  (add-scribe-directive-command nil "c" :Command #k"Control-k" "Scribe")
434    
435    
436    

Legend:
Removed from v.1.1  
changed lines
  Added in v.1.2

  ViewVC Help
Powered by ViewVC 1.1.5