cgit.sxemacs.org Git - packages/blob - xemacs-packages/psgml/psgml-fs.el

   1 ;;; psgml-fs.el --- Format a SGML-file according to a style file
   2 ;; Copyright (C) 1995, 2000 Lennart Staflin
   3
   4 ;; Author: Lennart Staflin <lenst@lysator.liu.se>
   5 ;; Version: $Id: psgml-fs.el,v 1.13 2002/07/14 10:03:26 lenst Exp $
   6 ;; Keywords:
   7
   8 ;;; This program is free software; you can redistribute it and/or modify
   9 ;;; it under the terms of the GNU General Public License as published by
  10 ;;; the Free Software Foundation; either version 2, or (at your option)
  11 ;;; any later version.
  12 ;;;
  13 ;;; This program is distributed in the hope that it will be useful,
  14 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  15 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16 ;;; GNU General Public License for more details.
  17 ;;;
  18 ;;; A copy of the GNU General Public License can be obtained from this
  19 ;;; program's author (send electronic mail to lenst@lysator.liu.se) or from
  20 ;;; the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA
  21 ;;; 02139, USA.
  22 ;;;
  23 ;;; Commentary:
  24
  25 ;; The function `style-format' formats the SGML-file in the current buffer
  26 ;; according to the style defined in the file `style.fs' (or the file given
  27 ;; by the variable `fs-style').
  28
  29 ;; To try it load this file and open the test file example.sgml. Then
  30 ;; run the emacs command `M-x style-format'.
  31
  32 ;; The style file should contain a single Lisp list.  The elements of
  33 ;; this list, lists themselves, describe the style for an element type.
  34 ;; The sublists begin with the generic identifier for the element types and
  35 ;; the rest of the lists are characteristic/value pairs.
  36
  37 ;; E.g.  ("p"  block t  left 4  top 2)
  38
  39 ;; Defines the style for p-elements to be blocks with left margin 4 and
  40 ;; at least two blank lines before the block.
  41
  42 \f
  43 ;;; Code:
  44 (provide 'psgml-fs) ;; XEmacs change
  45 (require 'psgml-api)
  46 (eval-when-compile (require 'cl)
  47                    (require 'ps-print))
  48
  49 ;;;; Formatting parameters
  50
  51 (defvar fs-char
  52   '((left . 0)
  53     (first . nil)
  54     (default-top . 0)
  55     (default-bottom . 0)
  56     (ignore-empty-para . nil)
  57     (literal . nil)))
  58
  59 (defvar fs-special-styles
  60   '(top bottom before after hang-from text sub-style title)
  61   "Style attributes that should not be entered in the characteristics table.")
  62
  63
  64 ;;; Dynamic variables
  65
  66 (defvar fs-current-element nil)
  67 (defvar fs-buffer)
  68
  69 \f
  70 ;;;; Formatting engine
  71
  72 (defun fs-char (p)
  73   (cdr (assq p fs-char)))
  74
  75 (defun fs-set-char (p val)
  76   (setcdr (assq p fs-char) val))
  77
  78 (defsetf fs-char fs-set-char)
  79
  80 (defvar fs-para-acc ""
  81   "Accumulate text of paragraph")
  82
  83 (defvar fs-hang-from nil
  84   "Hanging indent of current paragraph")
  85
  86 (defvar fs-first-indent nil)
  87 (defvar fs-left-indent nil)
  88
  89 (defvar fs-vspace 0
  90   "Vertical space after last paragraph")
  91
  92 (defvar fs-filename)
  93 (defvar fs-title)
  94
  95 (defun fs-add-output (str &optional just)
  96   (save-excursion
  97     (set-buffer fs-buffer)
  98     (goto-char (point-max))
  99     (let ((start (point)))
 100       (insert str)
 101       (when just
 102         (set-justification start (point) just)))))
 103
 104
 105 (defun fs-addvspace (n)
 106   (when (> n fs-vspace)
 107     (fs-add-output (make-string (- n fs-vspace) ?\n))
 108     (setq fs-vspace n)))
 109
 110
 111 (defun fs-para ()
 112   (when (if (fs-char 'ignore-empty-para)
 113             (string-match "[^\t\n ]" fs-para-acc)
 114           fs-left-indent)
 115     (assert fs-left-indent)
 116     (fs-output-para fs-para-acc fs-first-indent fs-left-indent
 117                     fs-hang-from
 118                     (fs-char 'literal))
 119     (setq fs-vspace 0
 120           fs-hang-from nil))
 121   (setq fs-para-acc ""
 122         fs-first-indent nil
 123         fs-left-indent nil))
 124
 125 (defun fs-paraform-data (data)
 126   (unless fs-left-indent
 127     (setq fs-left-indent (fs-char 'left)
 128           fs-first-indent (fs-char 'first)))
 129   (let ((face (fs-char 'face)))
 130     (when face
 131       (setq data (copy-sequence data))
 132       (put-text-property 0 (length data)
 133                          'face face data))
 134     (setq fs-para-acc (concat fs-para-acc data))))
 135
 136
 137 (defun fs-output-para (text first-indent indent hang-from literal)
 138   (sgml-push-to-string text)
 139   (let ((indent-tabs-mode nil)
 140         (fill-prefix (make-string indent ? )))
 141     (cond
 142      (literal
 143       (goto-char (point-max))
 144       (unless (bolp)
 145         (insert ?\n))
 146       (goto-char (point-min))
 147       (while (not (eobp))
 148         (insert fill-prefix)
 149         (beginning-of-line 2)))
 150      (t
 151       (while (re-search-forward "[ \t\n\r]+" nil t)
 152         (replace-match " "))
 153       (goto-char (point-min))
 154       (delete-horizontal-space)
 155       (insert
 156        (if hang-from
 157            hang-from
 158          (make-string (or first-indent indent) ? )))
 159       (fill-region-as-paragraph (point-min) (point-max))
 160       (goto-char (point-max))
 161       (unless (bolp)
 162         (insert ?\n))))
 163     (fs-add-output (buffer-string) (fs-char 'justification)))
 164   (sgml-pop-entity)
 165   (sit-for 0))
 166
 167 (defun fs-paraform-phrase (e)
 168   (sgml-map-content e
 169                     (function fs-paraform-phrase)
 170                     (function fs-paraform-data)
 171                     nil
 172                     (function fs-paraform-entity)))
 173
 174 (defun fs-paraform-entity (entity)
 175   (let ((entity-map (fs-char 'entity-map))
 176         (text nil))
 177     (when entity-map
 178       (setq text
 179             (loop for (name val) on entity-map by 'cddr
 180                   thereis (if (equal name (sgml-entity-name entity))
 181                               val))))
 182     (unless text
 183       (setq text (sgml-entity-text entity)))
 184     (fs-paraform-data text)))
 185 \f
 186 ;;;; Style driven engine
 187
 188 (defvar fs-style "style.fs"
 189   "*Style sheet to use for `style-format'.
 190 The value can be the style-sheet list, or it can be a file name
 191 \(string) of a file containing the style sheet or it can be the name
 192 \(symbol) of a variable containing the style sheet.")
 193
 194 (put 'fs-style 'variable-interactive
 195      "fStyle file: ")
 196
 197 (defvar fs-cached-styles nil)
 198
 199 (defun fs-get-style (style)
 200   (cond ((stringp style)
 201          (sgml-cache-catalog style
 202                              'fs-cached-styles
 203                              (function (lambda ()
 204                                          (read (current-buffer))))))
 205         ((symbolp style)
 206          (fs-get-style (symbol-value style)))
 207         ((listp style)
 208          style)
 209         (t
 210          (error "Illegal style value: %s" style))))
 211
 212 (defun fs-engine (e)
 213   (fs-do-style e
 214                (cdr (or (assoc (sgml-element-gi e) fs-style)
 215                         (assq t fs-style)))))
 216
 217 (defun fs-do-style (fs-current-element style)
 218   (let ((hang-from (eval (plist-get style 'hang-from))))
 219     (when hang-from
 220       (setq fs-hang-from
 221             (format "%s%s "
 222                     (make-string
 223                      (or (fs-char 'hang-left) (fs-char 'left))
 224                      ? )
 225                     hang-from))))
 226   (let ((fs-char (nconc
 227                   (loop for st on style by 'cddr
 228                         unless (memq (car st) fs-special-styles)
 229                         collect (cons (car st)
 230                                       (eval (cadr st))))
 231                   fs-char)))
 232     (when (plist-get style 'block)
 233       (fs-para)
 234       (fs-addvspace (or (plist-get style 'top)
 235                         (fs-char 'default-top))))
 236     (let ((before (plist-get style 'before)))
 237       (when before
 238         (fs-do-style e before)))
 239     (let ((fs-style
 240            (append (plist-get style 'sub-style)
 241                    fs-style)))
 242       (cond ((plist-get style 'text)
 243              (let ((text (eval (plist-get style 'text))))
 244                (when (stringp text)
 245                  (fs-paraform-data text))))
 246             (t
 247              (sgml-map-content e
 248                                (function fs-engine)
 249                                (function fs-paraform-data)
 250                                nil
 251                                (function fs-paraform-entity)))))
 252     (let ((title (plist-get style 'title)))
 253       (when title
 254         (setq title (eval title))
 255         (save-excursion
 256           (set-buffer fs-buffer)
 257           (setq fs-title title))))
 258     (let ((after (plist-get style 'after)))
 259       (when after
 260         (fs-do-style e after)))
 261     (when (plist-get style 'block)
 262       (fs-para)
 263       (fs-addvspace (or (plist-get style 'bottom)
 264                         (fs-char 'default-bottom))))))
 265
 266
 267 (defun fs-clear ()
 268   (setq fs-para-acc ""
 269         fs-hang-from nil
 270         fs-first-indent nil
 271         fs-left-indent nil
 272         fs-vspace 0)  )
 273
 274
 275 (defun fs-setup-buffer ()
 276   (save-excursion
 277     (let ((orig-filename (buffer-file-name (current-buffer))))
 278       (set-buffer fs-buffer)
 279       (erase-buffer)
 280       (setq ps-left-header
 281             '(fs-title fs-filename))
 282       (make-local-variable 'fs-filename)
 283       (setq fs-filename (file-name-nondirectory orig-filename))
 284       (make-local-variable 'fs-title)
 285       (setq fs-title ""))))
 286
 287 (defun fs-wrapper (buffer-name thunk)
 288   (fs-clear)
 289   (let ((fs-style (fs-get-style fs-style))
 290         (fs-buffer (get-buffer-create buffer-name)))
 291     (fs-setup-buffer)
 292     (funcall thunk)
 293     (fs-para)
 294     (save-excursion
 295       (set-buffer fs-buffer)
 296       (goto-char (point-min)))
 297     fs-buffer))
 298
 299
 300 ;;;###autoload
 301 (defun style-format ()
 302   (interactive)
 303   (fs-wrapper  "*Formatted*"
 304                (lambda ()
 305                  (display-buffer fs-buffer)
 306                  (fs-engine (sgml-top-element)))))
 307
 308 \f
 309 ;;;; Helper functions for use in style sheet
 310
 311 (defun fs-element (&rest moves)
 312   "Find current or related element."
 313   (let ((element fs-current-element))
 314     (while moves
 315       (case (pop moves)
 316         (parent (setq element (sgml-element-parent element)))
 317         (next   (setq element (sgml-element-next element)))
 318         (child  (setq element (sgml-element-content element)))))
 319     element))
 320
 321 (defun fs-element-content (&optional e)
 322   (unless e (setq e (fs-element)))
 323   (let ((fs-para-acc "") fs-first-indent fs-left-indent)
 324     (sgml-map-content e
 325                       (function fs-paraform-phrase)
 326                       (function fs-paraform-data)
 327                       nil
 328                       (function fs-paraform-entity))
 329     fs-para-acc))
 330
 331 (defun fs-attval (name &optional element)
 332   (sgml-element-attval (if element element (fs-element))
 333                        name))
 334
 335 (defun fs-child-number (&optional element)
 336   (let* ((element (or element (fs-element)))
 337          (parent (sgml-element-parent element))
 338          (child  (sgml-element-content parent))
 339          (number 0))
 340     (while (and child (not (eq child element)))
 341       (incf number)
 342       (setq child (sgml-element-next child)))
 343     number))
 344
 345
 346 (defun fs-element-with-id (id)
 347   (block func
 348     (let ((element (sgml-top-element)))
 349       (while (not (sgml-off-top-p element))
 350         (let ((attlist (sgml-element-attlist element)))
 351           (loop for attdecl in attlist
 352                 if (eq 'ID (sgml-attdecl-declared-value attdecl))
 353                 ;; XEmacs change: use equalp if compare-strings not avaialable.
 354                 do (if (or (and (fboundp 'compare-strings)
 355                                 (compare-strings id nil nil
 356                                                  (sgml-element-attval
 357                                                   element
 358                                                   (sgml-attdecl-name attdecl))
 359                                                  nil nil))
 360                            (equalp id (sgml-element-attval
 361                                        element (sgml-attdecl-name attdecl))))
 362                        (return-from func element))))
 363         ;; Next element
 364         (if (sgml-element-content element)
 365             (setq element (sgml-element-content element))
 366           (while (null (sgml-element-next element))
 367             (setq element (sgml-element-parent element))
 368             (if (sgml-off-top-p element)
 369                 (return-from func nil)))
 370           (setq element (sgml-element-next element)))))
 371     nil))
 372
 373
 374 (defun fs-split-tokens (s)
 375   "Split a string S into a list of tokens."
 376   (let ((result nil))
 377     (sgml-push-to-string s)
 378     (while (not (eobp))
 379       (skip-syntax-forward "-")
 380       (let ((start (point)))
 381         (skip-syntax-forward "^-")
 382         (when (/= start (point))
 383           (push (buffer-substring-no-properties start (point))
 384                 result))))
 385     (sgml-pop-entity)
 386     (nreverse result)))
 387
 388 \f
 389 ;;; fs.el ends here