← Back to branch summary

~registry/texmacs/trunk

« back to all changes in this revision

Viewing changes to src/TeXmacs/progs/convert/tmml/tmmltm.scm

  • Committer: mgubi
  • Date: 2009-06-04 15:13:41 UTC
  • Revision ID: svn-v4:64cb5145-927a-446d-8aed-2fb7b4773692:trunk:2717
Support for X11 TeXmacs.app on Mac

Show diffs side-by-side

added added

removed removed

Lines of Context:
src/TeXmacs/progs/convert/tmml/tmmltm.scm
1
 
 
2
 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3
 
;;
4
 
;; MODULE      : tmmltm.scm
5
 
;; DESCRIPTION : conversion of Xml trees to TeXmacs trees
6
 
;; COPYRIGHT   : (C) 2003  Joris van der Hoeven
7
 
;;
8
 
;; This software falls under the GNU general public license version 3 or later.
9
 
;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
10
 
;; in the root directory or <http://www.gnu.org/licenses/gpl-3.0.html>.
11
 
;;
12
 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
13
 
 
14
 
(texmacs-module (convert tmml tmmltm)
15
 
  (:use (convert tools tmconcat)))
16
 
 
17
 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
18
 
;; Provide the inverse functionality of tmmlout
19
 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
20
 
 
21
 
(define (xmlin-make tag attrs args impl)
22
 
  (if (nnull? attrs) (set! attrs (list (cons '@ attrs))))
23
 
  (if (and (nnull? args) (func? (car args) 'tm-attr))
24
 
      (begin
25
 
        (set! attrs (append attrs (list (car args))))
26
 
        (set! args (cdr args))))
27
 
  (if (and impl (not (and (== impl '!concat) (<= (length args) 1))))
28
 
      (set! args (list (cons impl args))))
29
 
  `(,tag ,@attrs ,@args))
30
 
 
31
 
(define (xmlin-special tag attrs l)
32
 
  (with args (map xmlin (list-filter l (lambda (x) (nstring? x))))
33
 
    (with doc? (list-or (map (lambda (x) (func? x 'tm-par)) args))
34
 
      (xmlin-make tag attrs args (if doc? '!document #f)))))
35
 
 
36
 
(define (xmlin-unspace x first? last? preserve?)
37
 
  (cond ((and (string? x) preserve?) x)
38
 
        ((string? x) (xml-unspace x first? last?))
39
 
        (else (xmlin x))))
40
 
 
41
 
(define (xmlin-unspace-args l first? preserve?)
42
 
  (cond ((null? l) l)
43
 
        ((null? (cdr l)) (list (xmlin-unspace (car l) first? #t preserve?)))
44
 
        (else (cons (xmlin-unspace (car l) first? #f preserve?)
45
 
                    (xmlin-unspace-args (cdr l) #f preserve?)))))
46
 
 
47
 
(define (xmlin-regular tag attrs* args*)
48
 
  (let* ((search '(xml:space "preserve"))
49
 
         (preserve? (in? search attrs*))
50
 
         (attrs (list-filter attrs* (lambda (x) (!= x search))))
51
 
         (args (xmlin-unspace-args args* #t preserve?)))
52
 
    (set! args (list-filter args (lambda (x) (!= x ""))))
53
 
    (if (and (null? args) (in? tag '(tm-arg tm-par))) (set! args '("")))
54
 
    (xmlin-make tag attrs args '!concat)))
55
 
 
56
 
(define (xmlin x)
57
 
  ;(display* "[xmlin] " x "\n")
58
 
  (if (npair? x) x
59
 
      (let* ((tag (car x))
60
 
             (attrs? (and (pair? (cdr x)) (func? (cadr x) '@)))
61
 
             (attrs (if attrs? (cdadr x) '()))
62
 
             (args (if attrs? (cddr x) (cdr x))))
63
 
        (cond ((== tag '*TOP*)
64
 
               (with r (xmlin-special tag attrs args)
65
 
                 (if (match? r '(*TOP* (*PI* xml :*) (TeXmacs (@ :*) :*)))
66
 
                     `(*TOP*
67
 
                       ,(cadr r)
68
 
                       (TeXmacs ,(cadr (caddr r))
69
 
                                (!stacked ,@(cddr (caddr r)))))
70
 
                     (xmlin-regular tag attrs args))))
71
 
              ((== tag '*PI*) x)
72
 
              ((== tag 'TeXmacs)
73
 
               (xmlin-special tag attrs args))
74
 
              ((list-or (map (lambda (x) (func? x 'tm-arg)) args))
75
 
               (xmlin-special tag attrs args))
76
 
              ((list-or (map (lambda (x) (func? x 'tm-par)) args))
77
 
               (xmlin-special tag attrs args))
78
 
              (else (xmlin-regular tag attrs args))))))
79
 
 
80
 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
81
 
;; Provide the inverse functionality of tmxml
82
 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
83
 
 
84
 
(define tmmltm-current-version "9.9.9.9")
85
 
 
86
 
(define (tmmltm-string s)
87
 
  (if (version-before? tmmltm-current-version "1.0.5.8")
88
 
      (old-xml-cdata->tm s)
89
 
      (utf8->cork s)))
90
 
 
91
 
(define (tmmltm-file version args)
92
 
  (with old-version tmmltm-current-version
93
 
    (set! tmmltm-current-version version)
94
 
    (with r `(!file (document (TeXmacs ,version) ,@(map tmmltm args)))
95
 
      (set! tmmltm-current-version old-version)
96
 
      r)))
97
 
 
98
 
(define (tmmltm-document l)
99
 
  (cons 'document (map (lambda (x) (tmmltm (cadr x))) l)))
100
 
 
101
 
(define (tmmltm-concat l)
102
 
  (with r (tmconcat-simplify (map tmmltm l))
103
 
    (cond ((null? r) "")
104
 
          ((null? (cdr r)) (car r))
105
 
          (else (cons 'concat r)))))
106
 
 
107
 
(define (tmmltm-with x)
108
 
  (with (tag attr arg) (tmmltm-regular (car x) (cdr x))
109
 
    `(with ,@(cdr attr) ,arg)))
110
 
 
111
 
(define (tmmltm-ungroup-attrs attrs)
112
 
  (if (null? attrs) attrs
113
 
      (cons* (xml-name->tm (symbol->string (caar attrs)))
114
 
             (cadar attrs)
115
 
             (tmmltm-ungroup-attrs (cdr attrs)))))
116
 
 
117
 
(define (tmmltm-attributed tag attrs args)
118
 
  (cond ((null? attrs) (cons tag args))
119
 
        ((== (car attrs) "tm-dyn")
120
 
         (tmmltm-attributed (string->symbol (xml-name->tm (cadr attrs)))
121
 
                           (cddr attrs)
122
 
                           (cons (symbol->string tag) args)))
123
 
        (else `(,tag (attr ,@attrs) ,@args))))
124
 
 
125
 
(define (tmmltm-arg x)
126
 
  ;(display* "x= " x "\n")
127
 
  ;(display* "test? " (func? x 'tm-arg 1) "\n")
128
 
  (if (func? x 'tm-arg 1)
129
 
      (with y (cadr x)
130
 
        ;(display* "y= " y "\n")
131
 
        (with r (tmmltm y)
132
 
          ;(display* "r= " r "\n")
133
 
          r))
134
 
      (tmmltm x)))
135
 
 
136
 
(define (tmmltm-args l)
137
 
  (map tmmltm-arg l))
138
 
 
139
 
(define (tmmltm-regular tag* args)
140
 
  (with tag (string->symbol (xml-name->tm (symbol->string tag*)))
141
 
    (cond ((and (pair? args) (func? (car args) '@))
142
 
           (tmmltm-attributed tag
143
 
                             (tmmltm-ungroup-attrs (cdar args))
144
 
                             (tmmltm-args (cdr args))))
145
 
          ((and (pair? args) (func? (car args) 'tm-attr))
146
 
           (tmmltm-attributed tag
147
 
                             (tmmltm-args (cdar args))
148
 
                             (tmmltm-args (cdr args))))
149
 
          (else (cons tag (tmmltm-args args))))))
150
 
 
151
 
(tm-define (tmmltm x)
152
 
  ;(display* "[tmmltm] ") (write x) (display* "\n")
153
 
  (cond ((string? x) (tmmltm-string x))
154
 
        ((and (func? x '*TOP*) (>= (length x) 3) (func? (caddr x) 'TeXmacs 2))
155
 
         (tmmltm (caddr x)))
156
 
        ((func? x '*TOP*) (tmmltm-concat (cdr x)))
157
 
        ((func? x '*PI*) x)
158
 
        ((func? x 'TeXmacs 2) (tmmltm-file (cadadr (cadr x)) (cdr (caddr x))))
159
 
        ((func? x '!document) (tmmltm-document (cdr x)))
160
 
        ((func? x '!concat) (tmmltm-concat (cdr x)))
161
 
        ((func? x 'with) (tmmltm-with x))
162
 
        ((and (func? x 'tm-sym 1) (string? (cadr x)))
163
 
         (string-append "<" (cadr x) ">"))
164
 
        (else (tmmltm-regular (car x) (cdr x)))))
165
 
 
166
 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
167
 
;; User interface
168
 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
169
 
 
170
 
(tm-define (parse-tmml s)
171
 
  (:type (-> string stree))
172
 
  (:synopsis "Parse a TeXmacs XML document @s.")
173
 
  (with raw-xml (parse-xml s)
174
 
    ;(display* "raw= " raw-xml "\n")
175
 
    (xmlin raw-xml)))
176
 
 
177
 
(tm-define (tmml->texmacs tmml)
178
 
  (:type (-> stree stree))
179
 
  (:synopsis "Convert an TeXmacs XML stree @s into TeXmacs.")
180
 
  (with doc (tmmltm tmml)
181
 
    (if (func? doc '!file 1)
182
 
        (tree->stree (upgrade-tmml (cadr doc)))
183
 
        doc)))