;;; 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
