|
2
|
1 ;;; psgml-fs.el --- Format a SGML-file according to a style file
|
|
0
|
2 ;; Copyright (C) 1995 Lennart Staflin
|
|
|
3
|
|
|
4 ;; Author: Lennart Staflin <lenst@lysator.liu.se>
|
|
70
|
5 ;; Version: $Id: psgml-fs.el,v 1.1.1.1 1996/12/18 22:43:36 steve Exp $
|
|
0
|
6 ;; Keywords:
|
|
2
|
7 ;; Last edited: Thu Mar 21 22:32:27 1996 by lenst@triton.lstaflin.pp.se (Lennart Staflin)
|
|
0
|
8
|
|
|
9 ;;; This program is free software; you can redistribute it and/or modify
|
|
|
10 ;;; it under the terms of the GNU General Public License as published by
|
|
|
11 ;;; the Free Software Foundation; either version 1, or (at your option)
|
|
|
12 ;;; any later version.
|
|
|
13 ;;;
|
|
|
14 ;;; This program is distributed in the hope that it will be useful,
|
|
|
15 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
|
16 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
|
17 ;;; GNU General Public License for more details.
|
|
|
18 ;;;
|
|
|
19 ;;; A copy of the GNU General Public License can be obtained from this
|
|
|
20 ;;; program's author (send electronic mail to lenst@lysator.liu.se) or from
|
|
|
21 ;;; the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA
|
|
|
22 ;;; 02139, USA.
|
|
|
23 ;;;
|
|
|
24 ;;; Commentary:
|
|
|
25
|
|
2
|
26 ;; The function `style-format' formats the SGML-file in the current
|
|
|
27 ;; buffer according to the style defined in the file `psgml-style.fs'
|
|
|
28 ;; (or the file given by the variable `fs-style').
|
|
0
|
29
|
|
|
30 ;; To try it load this file and open the test file example.sgml. Then
|
|
|
31 ;; run the emacs command `M-x style-format'.
|
|
|
32
|
|
|
33 ;; The style file should contain a single Lisp list. The elements of
|
|
|
34 ;; this list, are them self lists, describe the style for an element type.
|
|
|
35 ;; The sublists begin with the generic identifier for the element types and
|
|
|
36 ;; the rest of the list are characteristic/value pairs.
|
|
|
37
|
|
|
38 ;; E.g. ("p" block t left 4 top 2)
|
|
|
39
|
|
|
40 ;; Defines the style for p-elements to be blocks with left margin 4 and
|
|
|
41 ;; at least to blank lines before the block.
|
|
|
42
|
|
|
43
|
|
|
44 ;;; Code:
|
|
|
45 (require 'psgml-api)
|
|
|
46
|
|
|
47 ;;;; Formatting parameters
|
|
|
48
|
|
|
49 (defvar fs-char
|
|
|
50 '((left . 0)
|
|
|
51 (first . nil)
|
|
|
52 (default-top . 0)
|
|
|
53 (default-bottom . 0)
|
|
|
54 (ignore-empty-para . nil)
|
|
|
55 (literal . nil)))
|
|
|
56
|
|
|
57 (defvar fs-special-styles
|
|
|
58 '(top bottom before after hang-from text)
|
|
|
59 "Style attribues that should not be entered in the characteristics table.")
|
|
|
60
|
|
|
61
|
|
|
62 ;;;; Formatting engine
|
|
|
63
|
|
|
64 (defun fs-char (p)
|
|
|
65 (cdr (assq p fs-char)))
|
|
|
66
|
|
|
67 (defvar fs-para-acc ""
|
|
|
68 "Accumulate text of paragraph")
|
|
|
69
|
|
|
70 (defvar fs-hang-from nil
|
|
|
71 "Hanging indent of current pargraph")
|
|
|
72
|
|
|
73 (defvar fs-first-indent nil)
|
|
|
74 (defvar fs-left-indent nil)
|
|
|
75
|
|
|
76 (defvar fs-vspace 0
|
|
|
77 "Vertical space after last paragraph")
|
|
|
78
|
|
|
79 (defun fs-addvspace (n)
|
|
|
80 (when (> n fs-vspace)
|
|
|
81 (princ (make-string (- n fs-vspace) ?\n))
|
|
|
82 (setq fs-vspace n)))
|
|
|
83
|
|
|
84
|
|
|
85 (defun fs-para ()
|
|
|
86 (when (if (fs-char 'ignore-epmty-para)
|
|
|
87 (string-match "[^\t\n ]" fs-para-acc)
|
|
|
88 fs-left-indent)
|
|
|
89 (assert fs-left-indent)
|
|
|
90 (fs-output-para fs-para-acc fs-first-indent fs-left-indent
|
|
|
91 fs-hang-from
|
|
|
92 (fs-char 'literal))
|
|
|
93 (setq fs-vspace 0
|
|
|
94 fs-hang-from nil))
|
|
|
95 (setq fs-para-acc ""
|
|
|
96 fs-first-indent nil
|
|
|
97 fs-left-indent nil))
|
|
|
98
|
|
|
99 (defun fs-paraform-data (data)
|
|
|
100 (unless fs-left-indent
|
|
|
101 (setq fs-left-indent (fs-char 'left)
|
|
|
102 fs-first-indent (fs-char 'first)))
|
|
|
103 (setq fs-para-acc (concat fs-para-acc data)))
|
|
|
104
|
|
|
105 (defun fs-output-para (text first-indent indent hang-from literal)
|
|
|
106 (sgml-push-to-string text)
|
|
|
107 (let ((indent-tabs-mode nil)
|
|
|
108 (fill-prefix (make-string indent ? )))
|
|
|
109 (cond
|
|
|
110 (literal
|
|
|
111 (goto-char (point-max))
|
|
|
112 (unless (bolp)
|
|
|
113 (insert ?\n))
|
|
|
114 (goto-char (point-min))
|
|
|
115 (while (not (eobp))
|
|
|
116 (insert fill-prefix)
|
|
|
117 (beginning-of-line 2)))
|
|
|
118 (t
|
|
|
119 (while (re-search-forward "[ \t\n\r]+" nil t)
|
|
|
120 (replace-match " "))
|
|
|
121 (goto-char (point-min))
|
|
|
122 (delete-horizontal-space)
|
|
|
123 (insert
|
|
|
124 (if hang-from
|
|
|
125 hang-from
|
|
|
126 (make-string (or first-indent indent) ? )))
|
|
|
127 (fill-region-as-paragraph (point-min) (point-max))
|
|
|
128 ))
|
|
|
129 (princ (buffer-string)))
|
|
|
130 (sgml-pop-entity))
|
|
|
131
|
|
|
132 (defun fs-element-content (e)
|
|
|
133 (let ((fs-para-acc ""))
|
|
|
134 (sgml-map-content e
|
|
|
135 (function fs-paraform-phrase)
|
|
|
136 (function fs-paraform-data)
|
|
|
137 nil
|
|
|
138 (function fs-paraform-entity))
|
|
|
139 fs-para-acc))
|
|
|
140
|
|
|
141 (defun fs-paraform-phrase (e)
|
|
|
142 (sgml-map-content e
|
|
|
143 (function fs-paraform-phrase)
|
|
|
144 (function fs-paraform-data)
|
|
|
145 nil
|
|
|
146 (function fs-paraform-entity)))
|
|
|
147
|
|
|
148 (defun fs-paraform-entity (entity)
|
|
|
149 (let ((entity-map (fs-char 'entity-map))
|
|
|
150 (text nil))
|
|
|
151 (when entity-map
|
|
|
152 (setq text
|
|
|
153 (loop for (name val) on entity-map by 'cddr
|
|
|
154 thereis (if (equal name (sgml-entity-name entity))
|
|
|
155 val))))
|
|
|
156 (unless text
|
|
|
157 (setq text (sgml-entity-text entity)))
|
|
|
158 (fs-paraform-data text)))
|
|
|
159
|
|
|
160 ;;;; Style driven engine
|
|
|
161
|
|
2
|
162 (defvar fs-style "psgml-style.fs"
|
|
0
|
163 "*Style sheet to use for `style-format'.
|
|
|
164 The value can be the style-sheet list, or it can be a file name
|
|
|
165 \(string) of a file containing the style sheet or it can be the name
|
|
|
166 \(symbol) of a variable containing the style sheet." )
|
|
|
167
|
|
|
168 (defvar fs-cached-styles nil)
|
|
|
169
|
|
|
170 (defun fs-get-style (style)
|
|
|
171 (cond ((stringp style)
|
|
|
172 (sgml-cache-catalog style
|
|
|
173 'fs-cached-styles
|
|
|
174 (function (lambda ()
|
|
|
175 (read (current-buffer))))))
|
|
|
176 ((symbolp style)
|
|
|
177 (fs-get-style (symbol-value style)))
|
|
|
178 ((listp style)
|
|
|
179 style)
|
|
|
180 (t
|
|
|
181 (error "Illegal style value: %s" style))))
|
|
|
182
|
|
|
183 (defun fs-engine (e)
|
|
|
184 (fs-do-style e
|
|
|
185 (cdr (or (assoc (sgml-element-gi e) fs-style)
|
|
|
186 (assq t fs-style)))))
|
|
|
187
|
|
|
188 (defun fs-do-style (e style)
|
|
|
189 (let ((hang-from (getf style 'hang-from)))
|
|
|
190 (when hang-from
|
|
|
191 (setq fs-hang-from
|
|
|
192 (format "%s%s "
|
|
|
193 (make-string (fs-char 'left) ? )
|
|
|
194 (eval hang-from)))))
|
|
|
195 (let ((fs-char (nconc
|
|
|
196 (loop for st on style by 'cddr
|
|
|
197 unless (memq (car st) fs-special-styles)
|
|
|
198 collect (cons (car st)
|
|
|
199 (eval (cadr st))))
|
|
|
200 fs-char)))
|
|
|
201 (when (getf style 'block)
|
|
|
202 (fs-para)
|
|
|
203 (fs-addvspace (or (getf style 'top)
|
|
|
204 (fs-char 'default-top))))
|
|
|
205 (let ((before (getf style 'before)))
|
|
|
206 (when before
|
|
|
207 (fs-do-style e before)))
|
|
|
208 (cond ((getf style 'text)
|
|
|
209 (fs-paraform-data (eval (getf style 'text))))
|
|
|
210 (t
|
|
|
211 (sgml-map-content e
|
|
|
212 (function fs-engine)
|
|
|
213 (function fs-paraform-data)
|
|
|
214 nil
|
|
|
215 (function fs-paraform-entity))))
|
|
|
216 (let ((after (getf style 'after)))
|
|
|
217 (when after
|
|
|
218 (fs-do-style e after)))
|
|
|
219 (when (getf style 'block)
|
|
|
220 (fs-para)
|
|
|
221 (fs-addvspace (or (getf style 'bottom)
|
|
|
222 (fs-char 'default-bottom))))))
|
|
|
223
|
|
|
224 ;;;###autoload
|
|
|
225 (defun style-format ()
|
|
|
226 (interactive)
|
|
|
227 (setq fs-para-acc "")
|
|
|
228 (let ((fs-style (fs-get-style fs-style)))
|
|
|
229 (with-output-to-temp-buffer "*Formatted*"
|
|
|
230 (fs-engine (sgml-top-element))
|
|
|
231 (fs-para))))
|
|
|
232
|
|
|
233
|
|
|
234
|
|
|
235 ;;;; Helper functions for use in style sheet
|
|
|
236
|
|
|
237 (defun fs-attval (name)
|
|
|
238 (sgml-element-attval e name))
|
|
|
239
|
|
|
240
|
|
2
|
241 ;;; psgml-fs.el ends here
|
