← Back to branch summary

~ubuntu-branches/ubuntu/hardy/texmacs/hardy

« back to all changes in this revision

Viewing changes to TeXmacs/progs/convert/tmml/tmmlout.scm

  • Committer: Bazaar Package Importer
  • Author(s): Ralf Treinen
  • Date: 2004-04-19 20:34:00 UTC
  • Revision ID: james.westby@ubuntu.com-20040419203400-g4e34ih0315wcn8v
Tags: upstream-1.0.3-R2
Import upstream version 1.0.3-R2

Show diffs side-by-side

added added

removed removed

Lines of Context:
TeXmacs/progs/convert/tmml/tmmlout.scm
 
1
 
 
2
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
3
;;
 
4
;; MODULE      : tmmlout.scm
 
5
;; DESCRIPTION : generation of Xml from scheme expressions
 
6
;; COPYRIGHT   : (C) 2002  Joris van der Hoeven
 
7
;;
 
8
;; This software falls under the GNU general public license and comes WITHOUT
 
9
;; ANY WARRANTY WHATSOEVER. See the file $TEXMACS_PATH/LICENSE for details.
 
10
;; If you don't have this file, write to the Free Software Foundation, Inc.,
 
11
;; 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
 
12
;;
 
13
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
14
 
 
15
(texmacs-module (convert tmml tmmlout)
 
16
  (:use (convert tools output))
 
17
  (:export serialize-tmml))
 
18
 
 
19
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
20
;; Determining output layout
 
21
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
22
 
 
23
(define (tmmlout-big? doc)
 
24
  (cond ((not (pair? doc)) #f)
 
25
        ((func? doc '!document) #t)
 
26
        ((func? doc 'tformat) #t)
 
27
        ((func? doc 'table) #t)
 
28
        ((func? doc 'collection) #t)
 
29
        ((func? doc 'associate) #t)
 
30
        ((func? doc 'tm-par) #t)
 
31
        (else (list-or (map tmmlout-big? (cdr doc)))))
 
32
  ;#t
 
33
  )
 
34
 
 
35
(define (tmmlout-preserve-one? x first? last?)
 
36
  (cond ((func? x '!concat) (tmmlout-preserve? (cdr x) first? last?))
 
37
        ((not (string? x)) #f)
 
38
        ((and first? (string-starts? x " ")) #t)
 
39
        ((and last? (string-ends? x " ")) #t)
 
40
        (else (>= (string-search-forwards "  " 0 x) 0))))
 
41
 
 
42
(define (tmmlout-preserve? l first? last?)
 
43
  (if (null? l) #f
 
44
      (or (tmmlout-preserve-one? (car l) first? (and last? (null? (cdr l))))
 
45
          (tmmlout-preserve? (cdr l) #f last?))))
 
46
 
 
47
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
48
;; Outputting main flow
 
49
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
50
 
 
51
(define (tmmlout-indent plus big? preserve?)
 
52
  (cond (preserve? (noop))
 
53
        (big? (output-indent plus) (output-lf))
 
54
        (else (noop))))
 
55
 
 
56
(define (tmmlout-attr x)
 
57
  ;(display-err* "[tmmlout-attr] " x "\n")
 
58
  (output-text " " (symbol->string (car x)) "=")
 
59
  (output-verbatim "\"" (string-replace (cadr x) "\"" "\\\"") "\""))
 
60
 
 
61
(define (tmmlout-stacked-args l)
 
62
  (if (not (null? l))
 
63
      (begin
 
64
        (tmmlout (car l))
 
65
        (if (not (null? (cdr l)))
 
66
            (begin
 
67
              (output-lf)
 
68
              (output-lf)))
 
69
        (tmmlout-stacked-args (cdr l)))))
 
70
 
 
71
(define (tmmlout-args l big? preserve?)
 
72
  ;(display-err* "[tmmlout-args] " l ", " big? ", " preserve? "\n")
 
73
  (cond ((null? l) (noop))
 
74
        ((string? (car l))
 
75
         (if preserve?
 
76
             (output-verbatim (car l))
 
77
             (output-text (car l)))
 
78
         (tmmlout-args (cdr l) big? preserve?))
 
79
        ((func? (car l) '!concat)
 
80
         (tmmlout-args (cdar l) #f preserve?)
 
81
         (tmmlout-args (cdr l) big? preserve?))
 
82
        ((func? (car l) '!document)
 
83
         (tmmlout-args (cdar l) big? preserve?)
 
84
         (tmmlout-args (cdr l) big? preserve?))
 
85
        ((func? (car l) '!stacked)
 
86
         (tmmlout-stacked-args (cdar l))
 
87
         (tmmlout-args (cdr l) big? preserve?))
 
88
        (else
 
89
         (tmmlout (car l))
 
90
         (if (and big?
 
91
                  (pair? (cdr l))
 
92
                  (not (string? (car l)))
 
93
                  (not (string? (cadr l))))
 
94
             (begin
 
95
               (output-lf)
 
96
               (if (func? (cadr l) 'tm-par) (output-lf))))
 
97
         (tmmlout-args (cdr l) big? preserve?))))
 
98
 
 
99
(define (tmmlout-tag tag attrs args)
 
100
  ;(display-err* "[tmmlout-tag] " tag ", " attrs ", " args "\n")
 
101
  (let* ((big? (tmmlout-big? (cons tag args)))
 
102
         (preserve? (tmmlout-preserve? args #t #t)))
 
103
    (if preserve? (set! attrs `((xml:space "preserve") ,@attrs)))
 
104
    (output-text "<")
 
105
    (output-text (symbol->string tag))
 
106
    (for-each tmmlout-attr attrs)
 
107
    (if (null? args) (output-text "/"))
 
108
    (output-text ">")
 
109
    (if (not (null? args))
 
110
        (begin
 
111
          (tmmlout-indent 2 big? preserve?)
 
112
          (tmmlout-args args big? preserve?)
 
113
          (tmmlout-indent -2 big? preserve?)
 
114
          (output-text "</" (symbol->string tag) ">")))))
 
115
 
 
116
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
117
;; Main output routines
 
118
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
119
 
 
120
(define (tmmlout x)
 
121
  ;(display-err* "[tmmlout] " x "\n")
 
122
  (cond ((string? x) (output-text x))
 
123
        ((null? x) (noop))
 
124
        ((func? x '*PI*)
 
125
         (output-text "<?" (symbol->string (cadr x)) " " (caddr x) "?>"))
 
126
        ((and (pair? (cdr x)) (func? (cadr x) '@))
 
127
         (tmmlout-tag (car x) (cdadr x) (cddr x)))
 
128
        ((func? x '!concat) (tmmlout-args (cdr x) #f #t))
 
129
        ((func? x '!document) (tmmlout-args (cdr x) #t #f))
 
130
        ((func? x '!stacked) (tmmlout-stacked-args (cdr x)))
 
131
        ((func? x '*TOP*) (tmmlout-stacked-args (cdr x)))
 
132
        (else (tmmlout-tag (car x) '() (cdr x)))))
 
133
 
 
134
(define (serialize-tmml x)
 
135
  (tmmlout x)
 
136
  (output-produce))