← Back to branch summary

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

« back to all changes in this revision

Viewing changes to TeXmacs/progs/convert/rewrite/tmtm-tidy.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/rewrite/tmtm-tidy.scm
 
1
 
 
2
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
3
;;
 
4
;; MODULE      : tmtm-tidy.scm
 
5
;; DESCRIPTION : commodity routines for improving a document
 
6
;; COPYRIGHT   : (C) 2003  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 rewrite tmtm-tidy)
 
16
  (:export tmtm-modernize-newlines
 
17
           tmtm-eat-space-around-control
 
18
           tmtm-remove-superfluous-newlines
 
19
           tmtm-concat-document-correct))
 
20
 
 
21
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
22
;; Some useful subroutines
 
23
;; FIXME: concat- and document- correction should go elsewhere
 
24
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
25
 
 
26
(define (tmtm-concat l)
 
27
  (cond ((null? l) "")
 
28
        ((null? (cdr l)) (car l))
 
29
        (else (cons 'concat l))))
 
30
 
 
31
(define (tmtm-document-sub l)
 
32
  (cond ((null? l) l)
 
33
        ((func? (car l) 'document)
 
34
         (append (tmtm-document-sub (cdar l))
 
35
                 (tmtm-document-sub (cdr l))))
 
36
        (else (cons (car l) (tmtm-document-sub (cdr l))))))
 
37
 
 
38
(define (tmtm-document l)
 
39
  (with r (tmtm-document-sub l)
 
40
    (if (null? r) "" (cons 'document r))))
 
41
 
 
42
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
43
;; Transform formatting newlines into documents
 
44
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
45
 
 
46
(define (tmtm-new-line? x) (== x '(new-line)))
 
47
(define (tmtm-document? x) (func? x 'document))
 
48
 
 
49
(define (tmtm-modernize-newlines l)
 
50
  (if (not (list? l)) l
 
51
      (with r (cons (car l) (map tmtm-modernize-newlines (cdr l)))
 
52
        (cond ((func? r 'concat)
 
53
               (with ll (list-scatter (cdr r) tmtm-new-line? #f)
 
54
                 (if (< (length ll) 2) r
 
55
                     (tmtm-document (map tmtm-concat ll)))))
 
56
              ((func? r 'document) (tmtm-document (cdr r)))
 
57
              ((and (list-find (cdr r) tmtm-document?)
 
58
                    (not (list-find (cdr l) tmtm-document?)))
 
59
               (list 'document r))
 
60
              (else r)))))
 
61
 
 
62
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
63
;; Remove spaces before (and possibly after) control markup
 
64
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
65
 
 
66
(define (tmtm-control? l)
 
67
  (and (list? l) (in? (car l) '(label index))))
 
68
 
 
69
(define (tmtm-really-eat? l)
 
70
  (or (null? l)
 
71
      (and (string? (car l)) (string-starts? (car l) " "))
 
72
      (and (tmtm-control? (car l)) (tmtm-really-eat? (cdr l)))))
 
73
 
 
74
(define (tmtm-eat-before? l first?)
 
75
  ;; eat space before if possible and return #f otherwise
 
76
  (cond ((< (length l) 2) #f)
 
77
        ((not (and (string? (car l)) (string-ends? (car l) " "))) #f)
 
78
        ((not (tmtm-control? (cadr l))) #f)
 
79
        ((and (== (car l) " ") first?) (cdr l))
 
80
        ((tmtm-really-eat? (cdr l))
 
81
         (if (== (car l) " ")
 
82
             (cdr l)
 
83
             (cons (string-drop-right (car l) 1) (cdr l))))
 
84
        (else #f)))
 
85
 
 
86
(define (tmtm-eat-after? l first?)
 
87
  ;; eat space after if possible and return #f otherwise
 
88
  (cond ((or (null? l) (== l '(" "))) '())
 
89
        ((tmtm-control? (car l))
 
90
         (with r (tmtm-eat-after? (cdr l) first?)
 
91
           (if r (cons (car l) r) #f)))
 
92
        ((and (string? (car l)) (string-starts? (car l) " ") first?)
 
93
         (if (== (car l) " ") '() (list (string-drop (car l) 1))))
 
94
        (else #f)))
 
95
 
 
96
(define (tmtm-eat-around l first?)
 
97
  (with r (tmtm-eat-before? l first?)
 
98
    (cond (r (tmtm-eat-around r #f))
 
99
          ((null? l) l)
 
100
          ((tmtm-control? (car l))
 
101
           (with r (tmtm-eat-after? (cdr l) first?)
 
102
             (cons (car l) (tmtm-eat-around (if r r (cdr l)) #f))))
 
103
          (else (cons (car l) (tmtm-eat-around (cdr l) #f))))))
 
104
 
 
105
(define (tmtm-eat-space-around-control l)
 
106
  (if (not (list? l)) l
 
107
      (with r (map tmtm-eat-space-around-control (cdr l))
 
108
        (if (func? l 'concat)
 
109
            (tmtm-concat (tmtm-eat-around r #t))
 
110
            (cons (car l) r)))))
 
111
 
 
112
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
113
;; Remove superfluous newlines (i.e. remove empty paragraphs)
 
114
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
115
 
 
116
(define (tmtm-preserve-space? l)
 
117
  (and (list? l) (in? (car l) '(verbatim code))))
 
118
 
 
119
(define (tmtm-remove-superfluous-newlines l)
 
120
  (cond ((tmtm-preserve-space? l) l)
 
121
        ((func? l 'document)
 
122
         (with r (map tmtm-remove-superfluous-newlines (cdr l))
 
123
           (with f (list-filter r (lambda (x) (not (== x ""))))
 
124
             (if (null? f) '(document "") (cons 'document f)))))
 
125
        ((pair? l)
 
126
         (cons (car l) (map tmtm-remove-superfluous-newlines (cdr l))))
 
127
        (else l)))
 
128
 
 
129
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
130
;; Glue concats with document items in it to yield a document
 
131
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
132
 
 
133
(define (tmtm-concat-document-sub l)
 
134
  (if (null? (cdr l))
 
135
      (cdar l)
 
136
      (append (cdar l) (list (tmtm-concat (cdr l))))))
 
137
 
 
138
(define (tmtm-concat-document-correct l)
 
139
  ;; FIXME: might go into tmtm-concat constructor
 
140
  (if (not (list? l)) l
 
141
      (with r (cons (car l) (map tmtm-concat-document-correct (cdr l)))
 
142
        (if (and (func? r 'concat) (list-find (cdr r) tmtm-document?))
 
143
            (let* ((ll (list-scatter (cdr r) tmtm-document? #t))
 
144
                   (head (tmtm-concat (car ll)))
 
145
                   (aux (map tmtm-concat-document-sub (cdr ll)))
 
146
                   (tail (apply append aux)))
 
147
              (if (== head "")
 
148
                  (tmtm-document tail)
 
149
                  (tmtm-document (cons head tail))))
 
150
            r))))