;;; fs.el --- Format a SGML-file according to a style file
;; Copyright (C) 1995 Lennart Staflin

;; Author: Lennart Staflin <lenst@lysator.liu.se>
;; Version: $Id: psgml-fs.el,v 1.1.1.1 1996/12/18 03:35:17 steve Exp $
;; Keywords: 
;; Last edited: Mon Jan  8 22:12:00 1996 by lenst@triton.lstaflin.pp.se (Lennart Staflin)

;;; This program is free software; you can redistribute it and/or modify
;;; it under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 1, or (at your option)
;;; any later version.
;;;
;;; This program is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; A copy of the GNU General Public License can be obtained from this
;;; program's author (send electronic mail to lenst@lysator.liu.se) or from
;;; the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA
;;; 02139, USA.
;;;
;;; Commentary:

;; The function `style-format' formats the SGML-file in the current buffer
;; according to the style defined in the file `style.el' (or the file given
;; by the variable `fs-style').

;; To try it load this file and open the test file example.sgml. Then
;; run the emacs command `M-x style-format'.

;; The style file should contain a single Lisp list. The elements of
;; this list, are them self lists, describe the style for an element type. 
;; The sublists begin with the generic identifier for the element types and
;; the rest of the list are characteristic/value pairs.

;; E.g.  ("p"  block t  left 4  top 2)

;; Defines the style for p-elements to be blocks with left margin 4 and
;; at least to blank lines before the block.


;;; Code:
(require 'psgml-api)

;;;; Formatting parameters

(defvar fs-char
  '((left . 0)
    (first . nil)
    (default-top . 0)
    (default-bottom . 0)
    (ignore-empty-para . nil)
    (literal . nil)))

(defvar fs-special-styles
  '(top bottom before after hang-from text)
  "Style attribues that should not be entered in the characteristics table.")


;;;; Formatting engine

(defun fs-char (p)
  (cdr (assq p fs-char)))

(defvar fs-para-acc ""
  "Accumulate text of paragraph")

(defvar fs-hang-from nil
  "Hanging indent of current pargraph")

(defvar fs-first-indent nil)
(defvar fs-left-indent nil)

(defvar fs-vspace 0
  "Vertical space after last paragraph")

(defun fs-addvspace (n)
  (when (> n fs-vspace)
    (princ (make-string (- n fs-vspace) ?\n))
    (setq fs-vspace n)))
	   

(defun fs-para ()
  (when (if (fs-char 'ignore-epmty-para)
	    (string-match "[^\t\n ]" fs-para-acc)
	  fs-left-indent)
    (assert fs-left-indent)
    (fs-output-para fs-para-acc fs-first-indent fs-left-indent
		    fs-hang-from
		    (fs-char 'literal))
    (setq fs-vspace 0
	  fs-hang-from nil))
  (setq fs-para-acc ""
	fs-first-indent nil
	fs-left-indent nil))

(defun fs-paraform-data (data)
  (unless fs-left-indent
    (setq fs-left-indent (fs-char 'left)
	  fs-first-indent (fs-char 'first)))
  (setq fs-para-acc (concat fs-para-acc data)))

(defun fs-output-para (text first-indent indent hang-from literal)
  (sgml-push-to-string text)
  (let ((indent-tabs-mode nil)
	(fill-prefix (make-string indent ? )))
    (cond
     (literal
      (goto-char (point-max))
      (unless (bolp)
	(insert ?\n))
      (goto-char (point-min))
      (while (not (eobp))
	(insert fill-prefix)
	(beginning-of-line 2)))
     (t
      (while (re-search-forward "[ \t\n\r]+" nil t)
	(replace-match " "))
      (goto-char (point-min))
      (delete-horizontal-space)
      (insert 
       (if hang-from
	   hang-from
	 (make-string (or first-indent indent) ? )))
      (fill-region-as-paragraph (point-min) (point-max))
      ))
    (princ (buffer-string)))
  (sgml-pop-entity))

(defun fs-element-content (e)
  (let ((fs-para-acc ""))
    (sgml-map-content e
		      (function fs-paraform-phrase)
		      (function fs-paraform-data)
		      nil
		      (function fs-paraform-entity))
    fs-para-acc))

(defun fs-paraform-phrase (e)
  (sgml-map-content e
		    (function fs-paraform-phrase)
		    (function fs-paraform-data)
		    nil
		    (function fs-paraform-entity)))

(defun fs-paraform-entity (entity)
  (let ((entity-map (fs-char 'entity-map))
	(text nil))
    (when entity-map
      (setq text
	    (loop for (name val) on entity-map by 'cddr
		  thereis (if (equal name (sgml-entity-name entity))
			      val))))
    (unless text
      (setq text (sgml-entity-text entity)))
    (fs-paraform-data text)))

;;;; Style driven engine

(defvar fs-style "psgml-style.el"
  "*Style sheet to use for `style-format'.
The value can be the style-sheet list, or it can be a file name
\(string) of a file containing the style sheet or it can be the name
\(symbol) of a variable containing the style sheet." )

(defvar fs-cached-styles nil)

(defun fs-get-style (style)
  (cond ((stringp style)
	 (sgml-cache-catalog style
			     'fs-cached-styles
			     (function (lambda ()
					 (read (current-buffer))))))
	((symbolp style)
	 (fs-get-style (symbol-value style)))
	((listp style)
	 style)
	(t
	 (error "Illegal style value: %s" style))))

(defun fs-engine (e)
  (fs-do-style e
	       (cdr (or (assoc (sgml-element-gi e) fs-style)
			(assq t fs-style)))))

(defun fs-do-style (e style)
  (let ((hang-from (getf style 'hang-from)))
    (when hang-from
      (setq fs-hang-from 
	    (format "%s%s "
		    (make-string (fs-char 'left) ? )
		    (eval hang-from)))))
  (let ((fs-char (nconc
		  (loop for st on style by 'cddr
			unless (memq (car st) fs-special-styles)
			collect (cons (car st)
				      (eval (cadr st))))
		  fs-char)))
    (when (getf style 'block)
      (fs-para)
      (fs-addvspace (or (getf style 'top)
			(fs-char 'default-top))))
    (let ((before (getf style 'before)))
      (when before
	(fs-do-style e before)))
    (cond ((getf style 'text)
	   (fs-paraform-data (eval (getf style 'text))))
	  (t
	   (sgml-map-content e
			     (function fs-engine)
			     (function fs-paraform-data)
			     nil
			     (function fs-paraform-entity))))
    (let ((after (getf style 'after)))
      (when after
	(fs-do-style e after)))
    (when (getf style 'block)
      (fs-para)
      (fs-addvspace (or (getf style 'bottom)
			(fs-char 'default-bottom))))))

;;;###autoload
(defun style-format ()
  (interactive)
  (setq fs-para-acc "")
  (let ((fs-style (fs-get-style fs-style)))
    (with-output-to-temp-buffer "*Formatted*"
      (fs-engine (sgml-top-element))
      (fs-para))))
		 


;;;; Helper functions for use in style sheet

(defun fs-attval (name)
  (sgml-element-attval e name))


;;; fs.el ends here