psgml-jade.el, adds jade and jadetex support to psgml
From: http://www.uni-kiel.de:8080/Logik/persons/mc/psgml-jade.el
;;
;; psgml-jade.el --- add jade and jadetex support to psgml.
;; Copyright (C) 1997 Matthias Clasen.  Free redistribution permitted.
;; USE AT YOUR OWN RISK!
;;
;; Author: Matthias Clasen (clasen@netzservice.de)


;;; Commentary:

;; Thanks:
;;
;; The code is heavily borrowed from AUCTeX 9.5. 
;;
;;
;; Installation:
;;
;; This file requires Gnu Emacs 19.* or XEmacs, together with Lennart
;; Staflin's PSGML mode (tested with version 1.0.1) and David Megginson's 
;; DSSSL extensions (psgml-dsssl.el). 
;;
;; Install this file somewhere on your load path, byte-compile it, and
;; include the following somewhere in psgml.el
;;
;;   (load-library "psgml-jade")
;;
;; I have put it right after the comment line `;;;; Menu bar'
;; to make the menu appear at the right.
;;
;; Now, whenever you are editing an SGML document with PSGML, you will
;; see an additional menu with title "DSSSL". It contains entries to 
;; Jade, JadeTeX, Xdvi, David Megginson's `sgml-dsssl-make-spec' function
;; and two more entries to display the results of process and to kill a
;; running process. 
;;
;; For details how to customize the menu entries, see the documentation of
;; the variables below. 


;;; Code:

;;;; Variables to be customized.

(defvar  sgml-command-list 
  (list 
   (list "Jade" "jade -c%catalogs -t%backend -d%dsssl %file" 
	 'sgml-run-command nil)
   (list "JadeTeX" "jadetex '\\nonstopmode\\input %tex'" 'sgml-run-command nil)
   (list "View" "xdvi %dvi" 'sgml-run-background t)
   )
  "*List of commands. 

The first entry is the string appearing in the `DSSSL' menu,
the second entry is the command to run after expanding it with `sgml-command-expand',
the third one is the hook used to run the command,
the last entry might be t to indicate that the expanded command is to be confirmed
in the minibuffer.")

(defvar sgml-expand-list 
  (list 
   (list "%file" 'file 't)                ; the current file as is
   (list "%sgml" 'file "sgml")            ; the current file with extension "sgml"
   (list "%tex" 'file "tex")              ; the current file with extension "tex"
   (list "%dvi" 'file "dvi")              ; the current file with extension "dvi"
   (list "%dsssl" 'sgml-dsssl-spec)       ; the value of sgml-dsssl-spec
   (list "%backend" 'sgml-dsssl-backend)  ; the value of sgml-dsssl-backend
   (list "%catalogs" 'sgml-dsssl-catalogs 'sgml-catalog-files 'sgml-local-catalogs)
        ; the catalogs listed in sgml-catalog-files and sgml-local-catalogs.
   )
  "*List of matched patterns in commands.

The first entry is the placeholder in the command string, the
second entry is a function which is evaluated to produce a string replacing the
placeholder.

The function should accept all remaining list entries as arguments plus a first
argument which is a string holding a possible flag preceding the placeholder 
in the command string or the empty string if there is no flag.

If the replacement is more than one item (like for catalogs), the function would 
normally repeat the flag for each item.")

(defvar sgml-jade-backends 
  '(("TeX" . tex)
    ("RTF" . rtf)
    ("HTML" . html)
    ("FOT" . fot))
  "*List of supported backends for jade. 

Each backend is specified as a cons cell containing a string to appear in the 
`Jade backend' menu and a symbol whose name is used for the -t option of jade."  
)

(defvar sgml-show-compilation nil
  "*If non-nil, show output of compilation in other window.")

;;;; Internal variables.

;; This variable is chared with `compile.el'.
(defvar compilation-in-progress nil "List of compilation processes now running.")

(or (assq 'compilation-in-progress minor-mode-alist)
    (setq minor-mode-alist (cons '(compilation-in-progress " Compiling")
				 minor-mode-alist)))

(defvar sgml-dsssl-backend 'tex "*Backend to use with jade.")
(make-variable-buffer-local 'sgml-dsssl-backend)
(put 'sgml-dsssl-backend 'sgml-type sgml-jade-backends)
(put 'sgml-dsssl-backend 'sgml-desc "Jade backend")

(defvar sgml-dsssl-spec nil "*DSSSL Style sheet to use with jade.")
(make-variable-buffer-local 'sgml-dsssl-spec)
(put 'sgml-dsssl-spec 'sgml-type 'string-or-nil)
(put 'sgml-dsssl-spec 'sgml-desc "DSSSL style sheet")

(defconst sgml-dsssl-file-options
  '(
    sgml-dsssl-spec
    sgml-dsssl-backend
    )
  "Options for the current file, can be saved or set from menu."
  )

;;;; Command expansion   

(defun sgml-dsssl-backend (flag) 
  "Used in `sgml-command-expand' to produce the replacement text for %backend."
  (concat (when sgml-dsssl-backend flag) (symbol-name sgml-dsssl-backend))
  )

(defun sgml-dsssl-spec (flag) 
  "Used in `sgml-command-expand' to produce the replacement text for %dsssl."
  (concat (when sgml-dsssl-spec flag) sgml-dsssl-spec)
  )

(defun sgml-dsssl-catalogs (flag &rest lists)
  "Used in `sgml-command-expand' to produce the replacement text for %catalogs."
  (mapconcat 
   (lambda (cats) 
     (mapconcat (lambda (cat) (concat flag cat)) (eval cats) " "))
   lists " ")
)

(defun sgml-file (&optional extension) 
  "Return current file. Replace the extension by EXTENSION, if nonnil.
t is treated like \"sgml\"."
  (when (eq extension t) (setq extension "sgml"))
  (if extension
      (concat (sgml-strip-extension (buffer-file-name)) "." extension)
    (buffer-file-name)
    )
  )

(defun sgml-command-expand (command file)
  "Expand COMMAND for FILE as described by `sgml-expand-list'."
  (let ( (list sgml-expand-list) )
  (while list
    (let ( (case-fold-search nil)                 ; Do not ignore case.
	   (string (car (car list)))	          ; First element
	   (expansion (car (cdr (car list))))     ; Second element
	   (arguments (cdr (cdr (car list)))) )   ; Remaining elements
      (while (string-match (concat " \\(-.*\\|\\)" string) command)
	(let ( (prefix (substring command 0 (match-beginning 1)))
	       (flag (substring command (match-beginning 1) (match-end 1)))
	       (postfix (substring command (match-end 0))) )
	  (setq command 
		(concat prefix
			(cond ((sgml-function-p expansion)
			       (apply expansion flag arguments))
			      ((boundp expansion)
			       (concat flag (apply (eval expansion) arguments)))
			      (t
			       (error "Nonexpansion %s" expansion)))
			postfix)))))
    (setq list (cdr list)))
  command))

;;;; Hooks for `sgml-command-list'

(defun sgml-run-background (name command file)
  "Start process with second argument, show output when and if it arrives."
  (save-excursion
    (set-buffer (get-buffer-create "*SGML background*"))
    (erase-buffer))
  (let ((process (start-process (concat name " background")
				nil "/bin/sh" "-c" command)))
    (process-kill-without-query process)))

(defun sgml-run-command (name command file)
  "Hook for `sgml-command-list'."
  (let ( (buffer (sgml-process-buffer-name file)) )
    (sgml-process-check file)
    (get-buffer-create buffer)
    (set-buffer buffer)
    (erase-buffer)
    (insert "Running `" name "' on `" file "' with ``" command "''\n")
    (setq mode-name name)	
    (if sgml-show-compilation 
	(display-buffer buffer)
      (message "Type `C-c C-m' to display results of compilation."))
    (let ((process (start-process name buffer "/bin/sh" "-c" command)))
      (set-marker (process-mark process) (point-max))
      (setq compilation-in-progress (cons process compilation-in-progress))
      process)
    )
  )

(defun sgml-recenter-output-buffer (line)
  "Redisplay buffer of job output so that most recent output can be seen.
The last line of the buffer is displayed on line LINE of the window, or
at bottom if LINE is nil." 
  (interactive "P")
  (let ( (buffer (sgml-process-buffer (sgml-file))) )
    (if buffer
	(let ((old-buffer (current-buffer)))
	  (pop-to-buffer buffer t)
	  (bury-buffer buffer)
	  (goto-char (point-max))
	  (recenter (if line
			(prefix-numeric-value line)
		      (/ (window-height) 2)))
	  (pop-to-buffer old-buffer))
      (message "No process for this document."))))

;;;; Command execution

(defun sgml-command (name file)
  "Run the command NAME from `sgml-command-list' on FILE."
  (let* ( (entry (assoc name sgml-command-list))
	  (command (sgml-command-expand (nth 1 entry) file))
	  (hook (nth 2 entry))
	  (confirm (nth 3 entry)) )
    (if confirm
	(setq command
	      (read-from-minibuffer (concat name " command: ") command)))
    
    (apply hook name command (apply file nil) nil)))

(defun sgml-command-menu (name)
  "Execute command NAME from `sgml-command-list' from a menu."
  (sgml-command (car-safe (sgml-assoc name sgml-command-list)) 'sgml-file))

(defun sgml-kill-job ()
  (interactive)
  (let ( (process (sgml-process (sgml-file))) )
    (if process
	(kill-process process)
      (error "No process to kill"))))

;;;; Process handling 

(defun sgml-process-buffer-name (name)
  (concat "*" (abbreviate-file-name (expand-file-name name)) " output*"))

(defun sgml-process-buffer (name)
  (get-buffer (sgml-process-buffer-name name)))

(defun sgml-process (name)
  (get-buffer-process (sgml-process-buffer name)))

(defun sgml-process-check (name)
  "Check if a process for the document NAME already exists. If so, 
give the user the choice of aborting the process or the current command."
  (let ((process (sgml-process name)))
    (cond ((null process))
	  ((not (eq (process-status process) 'run)))
	  ((yes-or-no-p (concat "Process `"
				(process-name process)
				"' for document `"
				name
				"' running, kill it? "))
	   (delete-process process))
	  (t
	   (error "Cannot have two processes for the same document")))))

;;;; The menu
 
(defun sgml-jade-menu-entry (entry)
  "Return `sgml-jade-backends' entry ENTRY as a menu item."
  (vector (concat (car entry) )
	  (list 'setq 'sgml-dsssl-backend (car (cdr entry))) nil)
  )

(defun sgml-command-menu-entry (entry)
  "Return `sgml-command-list' entry ENTRY as a menu item."
  (let ( (name (car entry)) )
    (vector name (list 'sgml-command-menu name) t))
  )

(defun sgml-dsssl-file-options-menu (&optional event)
  (interactive "e")
  (sgml-options-menu event sgml-dsssl-file-options)
)

(easy-menu-define 
 sgml-command-menu sgml-mode-map "DSSSL menu"
 (append '("DSSSL")
	 (let ( (file 'buffer-file-name) )
	   (mapcar 'sgml-command-menu-entry sgml-command-list))
	 '("--"
	   ["File Options >" sgml-dsssl-file-options-menu t]
	   ["Make DSSSL style sheet" sgml-dsssl-edit-spec t]  
	   ["Recenter output buffer" sgml-recenter-output-buffer 
	    (sgml-process-buffer (sgml-file))]
	   ["Kill job" sgml-kill-job (sgml-process (sgml-file))]))
 )

;;;; Auxiliary functions

(defun sgml-function-p (arg)
  "Return non-nil if ARG is callable as a function."
  (or (and (fboundp 'byte-code-function-p)
	   (byte-code-function-p arg))
      (and (listp arg)
	   (eq (car arg) 'lambda))
      (and (symbolp arg)
	   (fboundp arg))))

(defun sgml-member (elt list how)
  "Returns the member ELT in LIST.  Comparison done with HOW.

Return nil if ELT is not a member of LIST."
  (while (and list (not (funcall how elt (car list))))
    (setq list (cdr list)))
  (car-safe list))

(defun sgml-assoc (elem list)
  "Like assoc, except case incentive."
  (let ((case-fold-search t))
    (sgml-member elem list
		(function (lambda (a b)
		  (string-match (concat "^" (regexp-quote a) "$")
				(car b)))))))

(defun sgml-strip-extension (name)
  "Return NAME with final `.*' stripped."
  (string-match "^\\(.*\\)[.][^.]*$" name)
  (substring name (match-beginning 1) (match-end 1))
  )


;;; rudimentary integration of psgml-dsssl.el with psgml-jade.el

(defun sgml-dsssl-ask-for-spec ()
  (let ( (dsssl (buffer-file-name)) )
    (save-excursion 
      (set-buffer sgml-current-sgml-buffer)
      (when (and
	     (not (equal sgml-dsssl-spec dsssl))
	     (y-or-n-p "Select style sheet ")
	     (setq sgml-dsssl-spec dsssl) 
	     )
	)
      )
    )  
  )

(defun sgml-dsssl-write ()
  (setq buffer-file-name 
   (expand-file-name (read-file-name 
     "File to save in: " "" 
     buffer-file-name nil buffer-file-name)))
  nil
)

(defun sgml-dsssl-edit-spec ()
  (interactive)
  (sgml-dsssl-make-spec)
  (setq sgml-current-sgml-buffer (current-buffer))
  (let* ( (name (sgml-file "dsl"))
	  (buffer (get-buffer "**DSSSL**")) 
	  (window (get-buffer-window buffer)) )
    (select-window window)
    (scheme-mode)
    (setq buffer-offer-save t)
    (setq buffer-file-name name)
    (make-local-variable 'after-save-hook)
    (add-hook 'after-save-hook 'sgml-dsssl-ask-for-spec)
    (add-hook 'local-write-file-hooks 'sgml-dsssl-write)
    )
  )


;;;; Autoload

(autoload 'sgml-dsssl-make-spec "psgml-dsssl" nil t)
(autoload 'sgml-options-menu "psgml-edit" nil t)

;;;; Provide

(provide 'psgml-jade)

;;; psgml-jade.el ends here