Commit b2f51b24 authored by Boris Goldowsky's avatar Boris Goldowsky
Browse files

Rewrite, many things moved to format.el.

parent 029894b9
......@@ -59,30 +59,6 @@ it will query you whether to fill.
Filling is never done if the current text-width is the same as the value
stored in the file.")
(defvar enriched-auto-save-interval 1000
"*`Auto-save-interval' to use for `enriched-mode'.
Auto-saving enriched files is slow, so you may wish to have them happen less
often. You can set this to nil to only do auto-saves when you are not
actively working.")
;;Unimplemented:
;(defvar enriched-aggressive-auto-fill t
; "*If t, try to keep things properly filled and justified always.
;Set this to nil if you have a slow terminal or prefer to justify on request.
;The difference between aggressive and non-aggressive is subtle right now, but
;may become stronger in the future.")
;; Unimplemented:
; (defvar enriched-keep-ignored-items nil
; "*If t, keep track of codes that are not understood.
; Otherwise they are deleted on reading the file, and not written out.")
;;Unimplemented:
;(defvar enriched-electric-indentation t
; "*If t, newlines and following indentation stick together.
;Deleting a newline or any part of the indenation will delete the whole
;stretch.")
;;;
;;; Set up faces & display table
;;;
......@@ -105,37 +81,11 @@ actively working.")
(if window-system
(make-face-italic 'excerpt)))
;;; The following two faces should not appear on menu.
(if (boundp 'facemenu-unlisted-faces)
(setq facemenu-unlisted-faces
(append '(enriched-code-face enriched-indentation-face)
facemenu-unlisted-faces)))
(if (internal-find-face 'enriched-code-face)
nil
(make-face 'enriched-code-face)
(if window-system
(set-face-background 'enriched-code-face
(if (x-display-color-p)
"LightSteelBlue"
"gray35"))))
(if (internal-find-face 'enriched-indentation-face)
nil
(make-face 'enriched-indentation-face)
(if window-system
(set-face-background 'enriched-indentation-face
(if (x-display-color-p)
"DarkSlateBlue"
"gray25"))))
(defvar enriched-display-table (make-display-table))
(defconst enriched-display-table (or (copy-sequence standard-display-table)
(make-display-table)))
(aset enriched-display-table ?\f (make-vector (1- (frame-width)) ?-))
; (defvar enriched-show-codes nil "See the function of the same name")
(defvar enriched-par-props '(left-margin right-margin justification
front-sticky)
(defconst enriched-par-props '(left-margin right-margin justification)
"Text-properties that usually apply to whole paragraphs.
These are set front-sticky everywhere except at hard newlines.")
......@@ -143,30 +93,21 @@ These are set front-sticky everywhere except at hard newlines.")
;;; Variables controlling the file format
;;; (bidirectional)
(defvar enriched-initial-annotation
(defconst enriched-initial-annotation
(lambda ()
(format "<param>-*-enriched-*-width:%d
</param>" (enriched-text-width)))
(format "Content-Type: text/enriched\nText-Width: %d\n\n"
(enriched-text-width)))
"What to insert at the start of a text/enriched file.
If this is a string, it is inserted. If it is a list, it should be a lambda
expression, which is evaluated to get the string to insert.")
(defvar enriched-annotation-format "<%s%s>"
(defconst enriched-annotation-format "<%s%s>"
"General format of enriched-text annotations.")
(defvar enriched-annotation-regexp "<\\(/\\)?\\([-A-za-z0-9]+\\)>"
(defconst enriched-annotation-regexp "<\\(/\\)?\\([-A-za-z0-9]+\\)>"
"Regular expression matching enriched-text annotations.")
(defvar enriched-downcase-annotations t
"Set to t if case of annotations is irrelevant.
In this case all annotations listed in enriched-annotation-list should be
lowercase, and annotations read from files will be downcased before being
compared to that list.")
(defvar enriched-list-valued-properties '(face unknown)
"List of properties whose values can be lists.")
(defvar enriched-annotation-alist
(defconst enriched-translations
'((face (bold-italic "bold" "italic")
(bold "bold")
(italic "italic")
......@@ -175,7 +116,6 @@ compared to that list.")
(excerpt "excerpt")
(default )
(nil enriched-encode-other-face))
(hard (nil enriched-encode-hard-newline))
(left-margin (4 "indent"))
(right-margin (4 "indentright"))
(justification (none "nofill")
......@@ -188,105 +128,24 @@ compared to that list.")
(FUNCTION (enriched-decode-foreground "x-color")
(enriched-decode-background "x-bg-color"))
(read-only (t "x-read-only"))
(unknown (nil enriched-encode-unknown)) ;anything else found
(unknown (nil format-annotate-value))
; (font-size (2 "bigger") ; unimplemented
; (-2 "smaller"))
)
"List of definitions of text/enriched annotations.
Each element is a list whose car is a PROPERTY, and the following
elements are VALUES of that property followed by zero or more ANNOTATIONS.
Whenever the property takes on that value, each of the annotations
will be inserted into the file. Only the name of the annotation
should be specified, it will be formatted by `enriched-make-annotation'.
At the point that the property stops having that value, the matching
negated annotation will be inserted (it may actually be closed earlier and
reopened, if necessary, to keep proper nesting).
Conversely, when annotations are read, they are searched for in this list, and
the relevant text property is added to the buffer. The first match found whose
conditions are satisfied is used. If enriched-downcase-annotations is true,
then annotations in this list should be listed in lowercase, and annotations
read from the file will be downcased.
If the VALUE is numeric, then it is assumed that there is a single annotation
and each occurrence of it increments the value of the property by that number.
Thus, given the entry \(left-margin \(4 \"indent\")), `enriched-encode-region'
will insert two <indent> annotations if the left margin changes from 4 to 12.
If the VALUE is nil, then instead of annotations, a function should be
specified. This function is used as a default: it is called for all
transitions not explicitly listed in the table. The function is called with
two arguments, the OLD and NEW values of the property. It should return a
list of annotations like `enriched-loc-annotations' does, or may directly
modify the buffer. Note that this only works for encoding; there must be some
other way of decoding the annotations thus produced.
[For future expansion:] If the VALUE is a list, then the property's value will
be appended to the surrounding value of the property.
For decoding, there are some special symbols that can be used in the
\"property\" slot. Annotations listed under the pseudo-property PARAMETER are
considered to be arguments of the immediately surrounding annotation; the text
between the opening and closing parameter annotations is deleted from the
buffer but saved as a string. The surrounding annotation should be listed
under the pseudo-property FUNCTION. Instead of inserting a text-property for
this annotation, enriched-decode-buffer will call the function listed in the
VALUE slot, with the first two arguments being the start and end locations and
the rest of the arguments being any PARAMETERs found in that region.")
;;; This is not needed for text/enriched format, since all annotations are in
;;; a standard form:
;(defvar enriched-special-annotations-alist nil
; "List of annotations not formatted in the usual way.
;Each element has the form (ANNOTATION BEGIN END), where
;ANNOTATION is the annotation's name, which is a symbol (normal
;annotations are named with strings, special ones with symbols),
;BEGIN is the literal string to insert as the opening annotation, and
;END is the literal string to insert as the close.
;This is used only for encoding. Typically, each will have an entry in
;enriched-decode-special-alist to deal with its decoding.")
;;; Encoding variables
(defvar enriched-encode-interesting-regexp "<"
"Regexp matching the start of something that may require encoding.
All text-property changes are also considered \"interesting\".")
(defvar enriched-encode-special-alist
'(("<" . (lambda () (insert-and-inherit "<"))))
"List of special operations for writing enriched files.
Each element has the form \(STRING . FUNCTION).
Whenever one of the strings \(including its properties, if any)
is found, the corresponding function is called.
Match data is available to the function.
See `enriched-decode-special-alist' for instructions on decoding special
items.")
(defvar enriched-ignored-ok
'(front-sticky rear-nonsticky)
"Properties that are not written into enriched files.
Generally this list should only contain properties that just for enriched's
internal purposes; other properties that cannot be recorded will generate
a warning message to the user since information will be lost.")
;;; Decoding variables
(defvar enriched-decode-interesting-regexp "[<\n]"
"Regexp matching the start of something that may require decoding.")
See `format-annotate-region' and `format-deannotate-region' for the definition
of this structure.")
(defvar enriched-decode-special-alist
'(("<<" . (lambda () (delete-char 1) (forward-char 1)))
("\n\n" . enriched-decode-hard-newline))
"List of special operations for reading enriched files.
Each element has the form \(STRING . FUNCTION).
Whenever one of the strings is found, the corresponding function is called,
with point at the beginning of the match and the match data is available to
the function. Should leave point where next search should start.")
(defconst enriched-ignore
'(front-sticky rear-nonsticky hard)
"Properties that are OK to ignore when saving text/enriched files.
Any property that is neither on this list nor dealt with by
`enriched-translations' will generate a warning.")
;;; Internal variables
(defvar enriched-mode nil
"True if `enriched-mode' \(which see) is enabled.")
"True if `enriched-mode' is in use.")
(make-variable-buffer-local 'enriched-mode)
(if (not (assq 'enriched-mode minor-mode-alist))
......@@ -305,144 +164,19 @@ them and their old values to `enriched-old-bindings'.")
The value is a list of \(VAR VALUE VAR VALUE...).")
(make-variable-buffer-local 'enriched-old-bindings)
(defvar enriched-translated nil
"True if buffer has already been decoded.")
(make-variable-buffer-local 'enriched-translated)
(defvar enriched-text-width nil)
(make-variable-buffer-local 'enriched-text-width)
(defvar enriched-ignored-list nil)
(defvar enriched-open-ans nil)
;;;
;;; Functions defining the format of annotations
;;;
(defun enriched-make-annotation (name positive)
"Format an annotation called NAME.
If POSITIVE is non-nil, this is the opening annotation, if nil, this is the
matching close."
;; Could be used for annotations not following standard form:
; (if (symbolp name)
; (if positive
; (elt (assq name enriched-special-annotations-alist) 1)
; (elt (assq name enriched-special-annotations-alist) 2)) )
(if (stringp name)
(format enriched-annotation-format (if positive "" "/") name)
;; has parameters.
(if positive
(let ((item (car name))
(params (cdr name)))
(concat (format enriched-annotation-format "" item)
(mapconcat (lambda (i) (concat "<param>" i "</param>"))
params "")))
(format enriched-annotation-format "/" (car name)))))
(defun enriched-annotation-name (a)
"Find the name of an ANNOTATION."
(save-match-data
(if (string-match enriched-annotation-regexp a)
(substring a (match-beginning 2) (match-end 2)))))
(defun enriched-annotation-positive-p (a)
"Returns t if ANNOTATION is positive (open),
or nil if it is a closing (negative) annotation."
(save-match-data
(and (string-match enriched-annotation-regexp a)
(not (match-beginning 1)))))
(defun enriched-encode-unknown (old new)
"Deals with re-inserting unknown annotations."
(cons (if old (list old))
(if new (list new))))
(defun enriched-encode-hard-newline (old new)
"Deal with encoding `hard-newline' property change."
;; This makes a sequence of N hard newlines into N+1 duplicates of the first
;; one- so all property changes are put off until after all the newlines.
(if (and new (current-justification)) ; no special processing inside NoFill
(let* ((length (skip-chars-forward "\n"))
(s (make-string length ?\n)))
(backward-delete-char (1- length))
(add-text-properties 0 length (text-properties-at (1- (point))) s)
(insert s)
(backward-char (+ length 1)))))
(defun enriched-decode-hard-newline ()
"Deal with newlines while decoding file."
(let ((nofill (equal "nofill" ; find out if we're in NoFill region
(enriched-which-assoc
'("nofill" "flushleft" "flushright" "center"
"flushboth")
enriched-open-ans)))
(n (skip-chars-forward "\n")))
(delete-char (- n))
(newline (if nofill n (1- n)))))
(defun enriched-encode-other-face (old new)
"Generate annotations for random face change.
One annotation each for foreground color, background color, italic, etc."
(cons (and old (enriched-face-ans old))
(and new (enriched-face-ans new))))
(defun enriched-face-ans (face)
"Return annotations specifying FACE."
(cond ((string-match "^fg:" (symbol-name face))
(list (list "x-color" (substring (symbol-name face) 3))))
((string-match "^bg:" (symbol-name face))
(list (list "x-bg-color" (substring (symbol-name face) 3))))
((let* ((fg (face-foreground face))
(bg (face-background face))
(props (face-font face t))
(ans (cdr (enriched-annotate-change 'face nil props))))
(if fg (enriched-push (list "x-color" fg) ans))
(if bg (enriched-push (list "x-bg-color" bg) ans))
ans))))
(defun enriched-decode-foreground (from to color)
(let ((face (intern (concat "fg:" color))))
(cond ((internal-find-face face))
((and window-system (facemenu-get-face face)))
(window-system
(enriched-warn "Color \"%s\" not defined:
Try M-x set-face-foreground RET %s RET some-other-color" color face))
((make-face face)
(enriched-warn "Color \"%s\" can't be displayed." color)))
(list from to 'face face)))
(defun enriched-decode-background (from to color)
(let ((face (intern (concat "bg:" color))))
(cond ((internal-find-face face))
((and window-system (facemenu-get-face face)))
(window-system
(enriched-warn "Color \"%s\" not defined:
Try M-x set-face-background RET %s RET some-other-color" color face))
((make-face face)
(enriched-warn "Color \"%s\" can't be displayed." color)))
(list from to 'face face)))
;;;
;;; NOTE: Everything below this point is intended to be independent of the file
;;; format, which is defined by the variables and functions above.
;;;
;;;
;;; Define the mode
;;;
;;;###autoload
(defun enriched-mode (&optional arg notrans)
(defun enriched-mode (&optional arg)
"Minor mode for editing text/enriched files.
These are files with embedded formatting information in the MIME standard
text/enriched format.
Turning the mode on or off interactively will query whether the buffer
should be translated into or out of text/enriched format immediately.
Noninteractively translation is done without query unless the optional
second argument NO-TRANS is non-nil.
Turning mode on runs `enriched-mode-hooks'.
Turning the mode on runs `enriched-mode-hooks'.
More information about enriched-mode is available in the file
etc/enriched.doc in the Emacs distribution directory.
......@@ -456,55 +190,40 @@ Commands:
(and enriched-mode (null arg)))
;; Turn mode off
(setq enriched-mode nil)
(if (if (interactive-p)
(y-or-n-p "Translate buffer into text/enriched format?")
(not notrans))
(progn (enriched-encode-region)
(mapcar (lambda (x)
(remove-text-properties
(point-min) (point-max)
(list (if (consp x) (car x) x) nil)))
(append enriched-ignored-ok
enriched-annotation-alist))
(setq enriched-translated nil)))
(setq buffer-file-format (delq 'text/enriched buffer-file-format))
;; restore old variable values
(while enriched-old-bindings
(funcall 'set (car enriched-old-bindings)
(car (cdr enriched-old-bindings)))
(setq enriched-old-bindings (cdr (cdr enriched-old-bindings))))
(remove-hook 'write-region-annotate-functions
'enriched-annotate-function t)
(remove-hook 'after-change-functions 'enriched-nogrow-hook t))
(setq enriched-old-bindings (cdr (cdr enriched-old-bindings)))))
(enriched-mode nil) ; Mode already on; do nothing.
(t ; Turn mode on
;; save old variable values before we change them.
(setq enriched-mode t
enriched-old-bindings
(list 'auto-save-interval auto-save-interval
'buffer-display-table buffer-display-table
(t (setq enriched-mode t) ; Turn mode on
(if (not (memq 'text/enriched buffer-file-format))
(setq buffer-file-format
(cons 'text/enriched buffer-file-format)))
;; Save old variable values before we change them.
;; These will be restored if we exit enriched-mode.
(setq enriched-old-bindings
(list 'buffer-display-table buffer-display-table
'indent-line-function indent-line-function
'use-hard-newlines use-hard-newlines))
(make-local-variable 'auto-save-interval)
'use-hard-newlines use-hard-newlines
'default-properties default-properties))
(make-local-variable 'indent-line-function)
(make-local-variable 'use-hard-newlines)
(setq auto-save-interval enriched-auto-save-interval
indent-line-function 'indent-to-left-margin
(make-local-variable 'default-properties)
(setq indent-line-function 'indent-to-left-margin
buffer-display-table enriched-display-table
use-hard-newlines t) ; Weird in Center&FlushRight
;; Add hooks
(add-hook 'write-region-annotate-functions
'enriched-annotate-function)
; (add-hook 'after-change-functions 'enriched-nogrow-hook)
(put-text-property (point-min) (point-max)
'front-sticky enriched-par-props)
(if (and (not enriched-translated)
(if (interactive-p)
(y-or-n-p "Does buffer need to be translated now? ")
(not notrans)))
(progn (enriched-decode-region)
(setq enriched-translated t)))
use-hard-newlines t)
(let ((sticky (get-text-property-default 'front-sticky))
(p enriched-par-props))
(while p
(if (not (memq (car p) sticky))
(setq sticky (cons (car p) sticky)))
(setq p (cdr p)))
(if sticky
(put-text-property-default 'front-sticky sticky)))
(run-hooks 'enriched-mode-hooks)))
(set-buffer-modified-p mod)
(force-mode-line-update)))
......@@ -524,340 +243,19 @@ Commands:
(cons (cons 'enriched-mode enriched-mode-map)
minor-mode-map-alist)))
(define-key enriched-mode-map "\C-a" 'move-to-left-margin)
(define-key enriched-mode-map "\C-j" 'newline)
(define-key enriched-mode-map "\M-j" 'enriched-justification-menu-map)
(define-key enriched-mode-map "\C-a" 'beginning-of-line-text)
(define-key enriched-mode-map "\C-m" 'reindent-then-newline-and-indent)
(define-key enriched-mode-map "\C-j" 'reindent-then-newline-and-indent)
(define-key enriched-mode-map "\M-j" 'facemenu-justification-menu)
(define-key enriched-mode-map "\M-S" 'set-justification-center)
(define-key enriched-mode-map "\C-x\t" 'increment-left-margin)
(define-key enriched-mode-map "\C-x\t" 'increase-left-margin)
(define-key enriched-mode-map "\C-c\C-l" 'set-left-margin)
(define-key enriched-mode-map "\C-c\C-r" 'set-right-margin)
;;(define-key enriched-mode-map "\C-c\C-s" 'enriched-show-codes)
;;;
;;; General list/stack manipulation
;;; Some functions dealing with text-properties, especially indentation
;;;
(defmacro enriched-push (item stack)
"Push ITEM onto STACK.
STACK should be a symbol whose value is a list."
(` (setq (, stack) (cons (, item) (, stack)))))
(defmacro enriched-pop (stack)
"Remove and return first item on STACK."
(` (let ((pop-item (car (, stack))))
(setq (, stack) (cdr (, stack)))
pop-item)))
(defun enriched-delq1 (cons list)
"Remove the given CONS from LIST by side effect.
Since CONS could be the first element of LIST, write
`(setq foo (enriched-delq1 element foo))' to be sure of changing the value
of `foo'."
(if (eq cons list)
(cdr list)
(let ((p list))
(while (not (eq (cdr p) cons))
(if (null p) (error "enriched-delq1: Attempt to delete a non-element"))
(setq p (cdr p)))
;; Now (cdr p) is the cons to delete
(setcdr p (cdr cons))
list)))
(defun enriched-make-list-uniq (list)
"Destructively remove duplicates from LIST.
Compares using `eq'."
(let ((l list))
(while l
(setq l (setcdr l (delq (car l) (cdr l)))))
list))
(defun enriched-make-relatively-unique (a b)
"Delete common elements of lists A and B, return as pair.
Compares using `equal'."
(let* ((acopy (copy-sequence a))
(bcopy (copy-sequence b))
(tail acopy))
(while tail
(let ((dup (member (car tail) bcopy))
(next (cdr tail)))
(if dup (setq acopy (enriched-delq1 tail acopy)
bcopy (enriched-delq1 dup bcopy)))
(setq tail next)))
(cons acopy bcopy)))
(defun enriched-common-tail (a b)
"Given two lists that have a common tail, return it.
Compares with `equal', and returns the part of A that is equal to the
equivalent part of B. If even the last items of the two are not equal,
returns nil."
(let ((la (length a))
(lb (length b)))
;; Make sure they are the same length
(while (> la lb)
(setq a (cdr a)
la (1- la)))
(while (> lb la)
(setq b (cdr b)
lb (1- lb))))
(while (not (equal a b))
(setq a (cdr a)
b (cdr b)))
a)
(defun enriched-which-assoc (items list)
"Return which one of ITEMS occurs first as a car of an element of LIST."
(let (res)
(while list
(if (setq res (member (car (car list)) items))
(setq res (car res)
list nil)
(setq list (cdr list))))
res))
(defun enriched-reorder (items order)
"Arrange ITEMS to following partial ORDER.
Elements of ITEMS equal to elements of ORDER will be rearranged to follow the
ORDER. Unmatched items will go last."
(if order
(let ((item (member (car order) items)))
(if item
(cons (car item)
(enriched-reorder (enriched-delq1 item items)
(cdr order)))
(enriched-reorder items (cdr order))))
items))
;;;
;;; Utility functions
;;;
(defun enriched-get-face-attribute (attr face &optional frame)
"Get an attribute of a face or list of faces.
ATTRIBUTE should be one of the functions `face-font' `face-foreground',
`face-background', or `face-underline-p'. FACE can be a face or a list of
faces. If optional argument FRAME is given, report on the face in that frame.
If FRAME is t, report on the defaults for the face in new frames. If FRAME is
omitted or nil, use the selected frame."
(cond ((null face) nil)
((or (symbolp face) (internal-facep face)) (funcall attr face frame))
((funcall attr (car face) frame))
((enriched-get-face-attribute attr (cdr face) frame))))
(defun enriched-overlays-overlapping (begin end &optional test)
"Return a list of the overlays which overlap the specified region.
If optional arg TEST is given, it is called with each overlay as its
argument, and only those for which it is true are returned."
(overlay-recenter begin)
(let ((res nil)
(overlays (cdr (overlay-lists)))) ; includes all ending after BEGIN
(while overlays
(if (and (< (overlay-start (car overlays)) end)
(or (not test)
(funcall test (car overlays))))
(enriched-push (car overlays) res))
(setq overlays (cdr overlays)))
res))
;(defun enriched-show-codes (&rest which)
; "Enable or disable highlighting of special regions.
;With argument null or `none', turns off highlighting.
;If argument is `newline', turns on display of hard newlines.
;If argument is `indent', highlights the automatic indentation at the beginning
;of each line.
;If argument is `margin', highlights all regions with non-standard margins."
; (interactive
; (list (intern (completing-read "Show which codes: "
; '(("none") ("newline") ("indent") ("margin"))
; nil t))))
; (if (null which)
; (setq enriched-show-codes nil)
; (setq enriched-show-codes which))
; ;; First delete current overlays
; (let* ((ol (overlay-lists))
; (overlays (append (car ol) (cdr ol))))
; (while overlays
; (if (eq (overlay-get (car overlays) 'face) 'enriched-code-face)
; (delete-overlay (car overlays)))
; (setq overlays (cdr overlays))))
; ;; Now add new ones for each thing displayed.
; (if (null which)
; (message "Code display off."))
; (while which
; (cond ((eq (car which) 'margin)
; (enriched-show-margin-codes))
; ((eq (car which) 'indent)