;;; jargon-mode.el --- major mode for editing the Jargon File definitions.
(require 'texinfo)
(defvar jargon-lexicon-files
'("lexicon1.tex" "lexicon2.tex" "lexicon3.tex" "lexicon4.tex"))
(define-minor-mode jargon-mode
"This is an enhanced Texinfo mode specialized for editing the Jargon File.
The extra commands supported are:
\\[jargon-find-entry] find a Jargon File entry
Find an entry by name. Return error if there is no such entry. Useful for
checking whether an entry exists without committing to edit it.
\\[jargon-edit-entry] edit a Jargon File entry
This command does all necessary things to open an edit of an existing or
new entry.
For a new entry, it creates an info node, adds a menu entry under the
proper letter node, adds an entry to the new-headword log, goes to the
proper place to start the entry, and inserts a headword macro call at
the right spot.
For an existing entry, it goes to that entry and adds a change
list entry referencing the current version. It does *not* check for
an existing change log entry, because the version number might
have been bumped."
:init-value nil
:interactive '(texinfo-mode)
:lighter " Jargon"
:keymap '(("\C-xt" . jargon-attribute)
("\C-c\C-e" . jargon-edit-entry)
("\C-c\C-f" . jargon-find-entry)
("\C-c\C-n" . jargon-next-entry))
:init-value nil
:global nil
(if (and jargon-mode (not (eq major-mode 'texinfo-mode)))
(texinfo-mode)))
(defun jargon-entry-file (tag)
"Visit the lexicon subfile containing a given entry."
(find-file
(let ((k (downcase (aref tag 0))))
(cond ((not (alpha-p k)) "lexicon1.tex")
((and (>= k ?a) (<= k ?d)) "lexicon1.tex")
((and (>= k ?e) (<= k ?k)) "lexicon2.tex")
((and (>= k ?l) (<= k ?r)) "lexicon3.tex")
; ((and (>= k ?s) (<= k ?z)) "lexicon4.tex")
(t "lexicon4.tex"))
)))
(defun fetch-info (file field)
"Fetch, from a given FILE, a given FIELD."
(with-temp-buffer
(find-file file)
(goto-char (point-min))
(and (re-search-forward field nil nil)
(buffer-substring (match-beginning 1) (match-end 1)))))
(defun match-nth-string (bn)
"Return the nth substring of the last regexp match."
(buffer-substring (match-beginning bn) (match-end bn)))
(defun smash-commas (str)
"Remove all commas from a string"
(with-temp-buffer
(insert str)
(goto-char (point-min))
(while (search-forward "," nil t) (replace-match ""))
(buffer-string)))
(defun canonicalize-node (str)
"Replace all tildes with spaces."
(while (not (= (char-syntax (aref str 0)) ?w))
(setq str (substring str 1)))
str)
(defun alpha-p (n)
"Is a char alphabetic?"
(or (and (>= n ?A) (<= n ?Z)) (and (>= n ?a) (<= n ?z))))
(defun jargon-headword-< (p q)
"Compare strings according to the Lexicon's dictionary sort order."
(string< (canonicalize-node (downcase p))
(canonicalize-node (downcase q))))
(defun jargon-find-entry (entry)
"Find entry with given headword via case-insensitive comparison."
(interactive "sKey: ")
(setq entry (canonicalize-node entry))
(jargon-entry-file entry)
(goto-char (point-min))
(prog1
(let ((case-fold-search t))
(re-search-forward (concat "^@hdt?{" entry "}") nil t))
(beginning-of-line)))
(defun jargon-next-entry ()
"Go to start of next entry."
(interactive)
(forward-line 1)
(if (re-search-forward "^@hdt?{" nil t)
(beginning-of-line)
(goto-char (1- (point-max)))
(re-search-backward "^$")
(forward-char 1)))
(defun jargon-prev-entry nil
"Go to start of previous entry"
(if (re-search-backward "^@hdt?{" nil t)
(beginning-of-line)
(goto-char (1+ (point-min)))
(re-search-forward "^$")
(backward-char 1)))
(defun jmail-get-posting-date ()
"Try to extract a date from the mail message we're in."
(save-excursion
(re-search-forward "^$" nil t)
(re-search-backward "^Date: [A-Z][a-z][a-z], \\([0-9][0-9]?\\) \\([A-Z][a-z][a-z]\\) \\([0-9]*\\) ")
(let ((day (match-nth-string 1))
(month (match-nth-string 2))
(year (match-nth-string 3)))
(if (= (length day) 1)
(setq day (concat "0" day)))
(if (= (length year) 2)
(setq year (concat "19" year)))
(concat day " " month " " year)
)))
(defun jmail-narrow-to-message nil
"Narrow scope of searches to current message in a mailbox file"
(save-excursion
(let (beg end)
(if (not (re-search-backward "\n\nFrom " nil t))
(goto-char (point-min)))
(setq beg (point))
(forward-line 1)
(if (not (re-search-forward "\n\nFrom " nil t))
(goto-char (point-max)))
(forward-line -1)
(setq end (point))
(narrow-to-region beg end))))
(defun jargon-get-attribution ()
(save-excursion
(let ((name))
(jmail-narrow-to-message)
(goto-char (point-min))
(mapc
(lambda (x)
(if (re-search-forward x nil t)
(progn
(if (not (fboundp 'mail-extract-address-components))
(load "mail-extr"))
(setq name (mail-extract-address-components
(buffer-substring
(point)
(save-excursion (end-of-line) (point))) )))
))
'("^Sender: " "^From: " "^Path: "))
(widen)
(concat
"from "
(car name)
" <"
(car (cdr name))
">, "
(jmail-get-posting-date)))))
(defun jargon-mark-entry (entry string)
"Append credit to entry's cite list."
(if (jargon-find-entry entry)
(progn
(jargon-next-entry)
(forward-line -1)
(while (looking-at "^$\\|^@unnumberedsec \\|^@node \\|^@ilindex\\|.*node-name,")
(forward-line -1))
(forward-line 1)
(insert "@comment " string "\n")
(message "Marking %s with %s" entry string)
(sit-for 0)
)))
(defun jargon-attribute (entry)
"Generate an attribution for a term from current message."
(interactive "sEntry: ")
(let ((attribution (jargon-get-attribution)))
(jargon-entry-file entry)
(jargon-mark-entry entry attribution)))
(defun jargon-current-version ()
(let (jargon-mode)
(fetch-info "Makefile" "VERSION *= *\\([0-9.]*\\(-queer\\)?\\)")))
(defun jargon-add-log (tag file &optional comment)
(save-excursion
(find-file file)
(set-mark (point-min))
(goto-char (point-max))
(insert " " tag)
(indent-to 56)
(insert (jargon-current-version))
(if comment
(insert " " comment))
(insert "\n")
(sort-lines nil (point-min) (point-max))
(basic-save-buffer)
(kill-buffer (current-buffer))))
(defun jargon-delete-log (tag file)
(save-excursion
(find-file file)
(if (search-forward tag nil t)
(progn
(beginning-of-line)
(sit-for 1)
(delete-region (point) (progn (forward-line 1) (point)))
(sit-for 1)
(basic-save-buffer))
(message "Can't find tag \"%s\" in logfile %s." tag file))
(kill-buffer (current-buffer))))
(defun jargon-this-headword ()
"Get the headword of the current entry."
(save-excursion
(re-search-forward "@hdt?{\\([^}]*\\)}")
(match-nth-string 1)))
(defun jargon-prev-headword ()
"Get the headword of the previous entry"
(save-excursion
(jargon-prev-entry)
(jargon-this-headword)))
(defun jargon-next-headword ()
"Get the headword of the next entry"
(save-excursion
(jargon-next-entry)
(jargon-this-headword)))
(defun get-alphakey ()
"Get the current alphanumeric key."
(save-excursion
(if (re-search-backward "= \\([A-Z]*\\) =" nil t)
(match-nth-string 1)
"unlettered")))
(defun jargon-make-node ()
(let ((next (smash-commas (jargon-next-headword)))
(current (smash-commas (jargon-this-headword)))
(prev (smash-commas (jargon-prev-headword)))
(alpha (get-alphakey)))
(if (string-match "," current)
(error "Comma in current-node name"))
(save-excursion
(forward-line -2)
(if (looking-at "^@node ")
(delete-region (point) (progn (forward-line 1) (point)))))
(insert "\n")
(forward-line -2)
(insert "@node " current ", " next ", " prev ", = " alpha " =")
(forward-line 2))
)
(defun jargon-goto-entry (tag)
"Go to an entry, or the next one up if it doesn't exist."
(interactive "sKey: ")
(jargon-entry-file tag)
(let (begin end pivot done cword)
(goto-char (point-min))
(jargon-next-entry)
(setq begin (point))
(goto-char (point-max))
(jargon-prev-entry)
(setq end (point))
(while (not done)
(goto-char (/ (+ begin end) 2))
(jargon-next-entry)
(if (= (point) end)
(jargon-prev-entry))
(if (= (point) begin)
(jargon-next-entry))
(setq pivot (point))
; (message "bottom %s, top %s, pivot %s"
; (save-excursion (goto-char begin) (jargon-this-headword))
; (save-excursion (goto-char end) (jargon-this-headword))
; (jargon-this-headword))
; (sit-for 1)
(if (setq done (= pivot end))
nil
(setq cword (jargon-this-headword))
(cond ((jargon-headword-< cword tag) (setq begin pivot))
((jargon-headword-< tag cword) (setq end pivot))
(t (setq done t)))))))
(defun jargon-edit-entry (tag comment)
"Edit an entry, logging the addition or change."
(interactive "sHeadword: \nsComment: ")
(jargon-goto-entry tag)
(if (string= (jargon-this-headword) tag)
(jargon-change-entry tag comment)
(jargon-new-entry tag comment)))
(defun jargon-change-entry (tag comment)
(jargon-add-log tag "jargon-chg.lst" comment))
(defun jargon-find-menu-entry (tag)
(re-search-backward "^@menu")
(forward-line 1)
(while (and (looking-at "^* \\(.*\\)::$")
(jargon-headword-< (match-nth-string 1) tag))
(forward-line 1)))
(defun jargon-new-entry (tag comment)
(if (not (= (aref (downcase (jargon-this-headword)) 0)
(aref (downcase (jargon-prev-headword)) 0)))
(re-search-backward "^@node *=")
(forward-line -2))
(insert "\n@hd{" tag "} @p{}\n\n")
(forward-line -2)
(beginning-of-line)
(save-excursion
(jargon-make-node)
(jargon-prev-entry)
(jargon-make-node)
(jargon-next-entry)
(jargon-next-entry)
(jargon-make-node)
(jargon-prev-entry)
(jargon-find-menu-entry tag)
(insert "* " tag "::\n")
(sit-for 0)
(jargon-add-log tag "jargon-new.lst" comment)
)
(forward-line 1)
(end-of-line))
(defun jargon-delete-entry (entry)
"Remove entry with given headword."
(interactive "sEntry to be deleted: ")
(if (not (jargon-find-entry entry))
(error "No such entry.")
(forward-line -1)
(append-to-file
(point)
(save-excursion
(jargon-next-entry)
(jargon-next-entry)
(forward-line -2)
(insert "@comment deleted " (jargon-current-version) "\n");
(point))
"chaff.tex")
(forward-line -1)
(delete-region
(point)
(progn
(jargon-next-entry)
(jargon-next-entry)
(forward-line -2)
(point)))
(save-excursion
(jargon-find-menu-entry entry) (sit-for 1)
(delete-region (point) (progn (forward-line 1) (point))) (sit-for 1))
(save-excursion
(jargon-prev-entry)
(jargon-make-node)
(jargon-next-entry)
(jargon-make-node))
(save-excursion
(jargon-add-log entry "jargon-del.lst")
(jargon-delete-log entry "jargon-new.lst")
(jargon-delete-log entry "jargon-chg.lst"))))
(defun jargon-move-entry (from to)
"Move entry FROM to just after entry TO."
(interactive "sFrom entry: \nsAfter entry: ")
(if (not (jargon-find-entry to))
(error "No such to entry"))
(if (not (jargon-find-entry from))
(error "No such from entry"))
(forward-line -2)
(kill-region (point)
(progn
(jargon-next-entry)
(jargon-next-entry)
(forward-line -2)
(point)))
(forward-line 2)
(jargon-make-node)
(jargon-prev-entry)
(jargon-make-node)
(save-excursion
(re-search-backward "^@menu")
(search-forward (concat "* " from "::"))
(beginning-of-line 1)
(sit-for 1)
(delete-region (point) (progn (forward-line 1) (point)))
(sit-for 1))
(save-buffer)
(jargon-find-entry to)
(jargon-next-entry)
(forward-line -2)
(yank)
(forward-line 2)
(jargon-make-node)
(jargon-prev-entry)
(jargon-make-node)
(jargon-prev-entry)
(jargon-make-node)
(save-excursion
(jargon-find-menu-entry to)
(forward-line 1)
(insert "* " from "::\n")
(sit-for 1))
(jargon-next-entry)
(save-buffer)
)
(defun jargon-make-info nil
"Format the file into an info file, expanding all enclosures.
Intended to be invoked from a batch-mode Emacs."
(interactive)
(setq load-path (cons "." load-path))
(find-file "jargon.tex")
(require 'texinfmt)
(let ((texinfo-suppress-fonts nil))
(texinfo-format-buffer t))
(save-some-buffers t)
(save-buffers-kill-emacs))
(defun jargon-remake-nodesec ()
"Remake the @nodesec header associated with an entry"
(interactive)
(beginning-of-line)
(if (looking-at "^@node[ \t]*\\([^,]*\\),\\([^,]*\\),\\(.*\\)")
(let ((name (buffer-substring (match-beginning 1) (match-end 1))))
(forward-line 1)
(if (cond ((looking-at "^@nodesec") (kill-line) t)
((looking-at "^$") (insert "\n") (forward-char -1) t)
(t nil))
(insert "@nodesec " name)))))
(defun jargon-fix-nodesecs ()
"Generate correct @nodesec headers for the lexicon files."
(interactive)
(mapcar
(function (lambda (f)
(find-file f)
(goto-char (point-min))
(while (re-search-forward "^@node " nil t)
(jargon-remake-nodesec))
(save-some-buffers t)))
jargon-lexicon-files))
(provide 'jargon)
;;; jargon-mode.el ends here
|