source: project/release/3/strictly-pretty/tags/1.3/strictly-pretty.scm @ 12566

Last change on this file since 12566 was 12566, checked in by Ivan Raikov, 13 years ago

Created release 1.3

File size: 7.9 KB
Line 
1
2;;
3;; _Strictly Pretty_
4;; Christian Lindig
5;;
6;; Adapted for Chicken Scheme by Ivan Raikov.
7;; Copyright 2008 Ivan Raikov and the Okinawa Institute of Science and Technology
8;;
9;; This program is free software: you can redistribute it and/or
10;; modify it under the terms of the GNU General Public License as
11;; published by the Free Software Foundation, either version 3 of the
12;; License, or (at your option) any later version.
13;;
14;; This program is distributed in the hope that it will be useful, but
15;; WITHOUT ANY WARRANTY; without even the implied warranty of
16;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
17;; General Public License for more details.
18;;
19;; A full copy of the GPL license can be found at
20;; <http://www.gnu.org/licenses/>.
21;;
22;;
23
24(require-extension syntax-case)
25(require-extension matchable)
26(require-extension datatype)
27(require-extension srfi-1)
28
29(define-extension strictly-pretty)
30
31(declare (export doc? doc:cons doc:empty doc:empty? doc:text 
32                 doc:nest doc:break doc:break-with doc:group doc:concat 
33                 doc:binop doc:ifthen doc:list doc:block doc:letblk
34                 doc:space doc:comma doc:connect
35                 doc:display doc:format sdoc? sdoc->string))
36
37
38(define (spaces n)  (list->string (list-tabulate n (lambda (x) #\space))))
39
40
41(define-datatype doc doc?
42  (DocNil)
43  (DocCons   (car doc?) (cdr doc?))
44  (DocText   (text string?))
45  (DocNest   (level integer?) (body doc?))
46  (DocBreak  (sep string?))
47  (DocGroup  (group doc?)))
48
49(define-datatype sdoc sdoc?
50  (SNil)
51  (SText (text string?) (next sdoc?))
52  (SLine (indent integer?) (body sdoc?)))
53
54(define-datatype mode mode?
55  (Flat)
56  (Break))
57
58
59(define-record-printer (mode x out)
60  (cases mode x
61         (Flat () (fprintf out "#(mode Flat)"))
62         (Break () (fprintf out "#(mode Break)"))))
63
64(define-record-printer (sdoc x out)
65  (cases sdoc x
66         (SNil ()     (fprintf out "#(SNil)"))
67         (SText (t n) (fprintf out "#(SText ~S ~A)" t n))
68         (SLine (i d) (fprintf out "#(SLine (~A, ~A))" i d))))
69
70(define-record-printer (doc x out)
71  (cases doc x
72         (DocNil ()     (fprintf out "#(DocNil)"))
73         (DocCons (x y) (fprintf out "#(DocCons ~A ~A)" x y))
74         (DocText (s)   (fprintf out "#(DocText ~A)" s))
75         (DocNest (i d) (fprintf out "#(DocNest (~A, ~A))" i d))
76         (DocBreak (s)  (fprintf out  "#(DocBreak ~S)" s))
77         (DocGroup (g)  (fprintf out  "#(DocGroup ~A)" g))))
78
79
80
81(define (doc:cons x y)  (DocCons x y))
82(define (doc:empty)     (DocNil))
83(define (doc:text s)    (DocText s))
84(define (doc:nest i x)  (DocNest i x))
85(define (doc:break)     (DocBreak " "))
86(define (doc:break-with s)  (DocBreak s)) 
87(define (doc:group x)   (DocGroup x))
88
89(define (doc:empty? x)     (and (doc? x) (cases doc x (DocNil () #t) (else #f))))
90
91(define (doc:connect x y)
92  (cases doc x
93         (DocNil ()   y)
94         (else   (cases doc y 
95                        (DocNil () x)
96                        (else (doc:cons x (doc:cons (doc:break) y)))))))
97
98(define (doc:connect-with s x y)
99  (cases doc x
100         (DocNil ()   y)
101         (else   (cases doc y 
102                        (DocNil () x)
103                        (else (doc:cons x (doc:cons (doc:break-with s) y)))))))
104
105(define (doc:concat lst)
106  (match lst
107         (()     (doc:empty))
108         (( x )  (doc:group x))
109         (( x . rest)  (cases doc x 
110                              (DocNil ()  (doc:concat rest))
111                              (else       (doc:cons x (doc:concat rest)))))
112         (else (error "doc:concat: invalid  doc list"))))
113
114(define (doc:fits w x)
115  (if (< w 0) #f
116      (match x
117             (()  #t)
118             ((( i m x ) . rest)  (cases doc x
119                                       (DocNil   ()     (doc:fits w rest))
120                                       (DocCons  (x y)  (doc:fits w (cons (list i m x) (cons (list i m y) rest))))
121                                       (DocNest  (j x)  (doc:fits w (cons (list (+ i j) m x) rest)))
122                                       (DocText  (s)    (doc:fits (- w (string-length s)) rest))
123                                       (DocGroup (x)    (doc:fits w (cons (list i (Flat) x) rest)))
124                                       (DocBreak (s)    (cases mode m 
125                                                               (Flat ()  (doc:fits (- w (string-length s)) rest))
126                                                               (Break () #t)))))
127             (else (error "doc:fits: invalid doc list")))))
128
129(define (format1 w k x)
130  (match x 
131         (()   (SNil))
132         ((( i m x ) . rest)  (cases doc x
133                                     (DocNil ()      (format1 w k rest))
134                                     (DocCons (x y)  (format1 w k (cons (list i m x) (cons (list i m y) rest))))
135                                     (DocNest (j x)  (format1 w k (cons (list (+ i j) m x) rest)))
136                                     (DocText (s)    (SText s (format1 w (+ k (string-length s)) rest)))
137                                     (DocGroup (x)   (if (doc:fits (- w k) (cons (list i (Flat) x) rest))
138                                                         (format1 w k (cons (list i (Flat) x) rest))
139                                                         (format1 w k (cons (list i (Break) x) rest))))
140                                     (DocBreak (s)   (cases mode m
141                                                            (Flat ()  (SText s (format1 w (+ k (string-length s)) rest)))
142                                                            (Break () (SText s (SLine i (format1 w i rest))))))))
143         (else (error "doc:format1: invalid doc list"))))
144         
145(define (doc:format w x) (format1 w 0 (list (list 0 (Flat) (DocGroup x)))))
146
147
148(define (sdoc->string x)
149  (let loop ((port (open-output-string)) (x x))
150    (cases sdoc x
151           (SNil ()      (get-output-string port))
152           (SText (s d)  (begin
153                           (display s port) 
154                           (loop port d)))
155           (SLine (i d)  (let ((prefix (make-string i #\space)))
156                           (display "\n" port)
157                           (display prefix port)
158                           (loop port d))))))
159
160
161(define (PNil) (void))
162(define (PText str next) 
163  (display str)
164  (next))
165(define (PLine indent body)
166  (display (spaces indent))
167  (body))
168 
169(define (doc:display1 w k x)
170  (match x 
171         (()   (PNil))
172         ((( i m x ) . rest) 
173          (cases doc x
174                 (DocNil ()      (doc:display1 w k rest))
175                 (DocCons (x y)  (doc:display1 w k (cons (list i m x) (cons (list i m y) rest))))
176                 (DocNest (j x)  (doc:display1 w k (cons (list (+ i j) m x) rest)))
177                 (DocText (s)    (PText s (lambda () (doc:display1 w (+ k (string-length s)) rest))))
178                 (DocGroup (x)   (if (doc:fits (- w k) (cons (list i (Flat) x) rest))
179                                     (doc:display1 w k (cons (list i (Flat) x) rest))
180                                     (doc:display1 w k (cons (list i (Break) x) rest))))
181                 (DocBreak (s)   (cases mode m
182                                        (Flat ()  (PText s (lambda () (doc:display1 w (+ k (string-length s)) rest))))
183                                        (Break () (PText s (lambda () (PLine i (doc:display1 w i rest)))))))))
184         (else (error "doc:display1: invalid doc list " x))))
185         
186(define (doc:display w x) (doc:display1 w 0 (list (list 0 (Flat) (DocGroup x)))))
187
188
189(define (doc:binop indent)
190  (lambda (left oper right)
191    (doc:group (doc:nest indent (doc:connect (doc:group (doc:connect left oper)) right)))))
192
193(define (doc:list indent elem->doc sep)
194  (define (ll ax lst)
195    (match lst
196           (()  (reverse ax))
197           ((x) (reverse (cons (doc:group (doc:nest indent (elem->doc x))) ax)))
198           ((x . rest)  (ll (cons (sep) (cons (doc:group (doc:nest indent (elem->doc x))) ax)) rest))))
199       
200  (lambda (lst)
201    (doc:group (doc:concat (ll (list) lst)))))
202
203(define (doc:ifthen indent i t e)
204  (lambda (c e1 e2)
205    (doc:group 
206     (doc:nest indent 
207               (doc:connect (doc:connect i c)
208                            (doc:connect (doc:group (doc:nest indent (doc:connect t e1)))
209                                         (doc:group (doc:nest indent (doc:connect e e2)))))))))
210   
211(define (doc:block indent open close)
212  (lambda (b)
213    (doc:group (doc:cons open (doc:cons (doc:nest indent b) close)))))
214
215(define (doc:letblk indent l i e)
216  (lambda (e1 e2)
217    (if (doc:empty? e1) e2
218        (doc:group (doc:connect (doc:nest indent (doc:connect l (doc:group e1)))
219                                (doc:connect (doc:nest indent (doc:connect i (doc:group e2))) e))))))
220       
221
222(define (doc:space)  (doc:text " "))
223                     
224(define (doc:comma)  (doc:break-with ", "))
225                     
226; Examples:
227#|
228(define cond1 ((doc:binop 2) (doc:text "a") (doc:text "==") (doc:text "b")))
229(define e1    ((doc:binop 2) (doc:text "a") (doc:text "<<") (doc:text "2")))
230(define e2    ((doc:binop 2) (doc:text "c") (doc:text "+") (doc:text "d")))
231
232(define doc1 ((doc:ifthen 2 (doc:text "if") (doc:text "then") (doc:text "else"))
233              cond1 e1 e2))
234
235(define doc2 ((doc:block 2 (doc:text "(") (doc:text ")")) doc1))
236
237(define doc3 ((doc:list 2 (lambda (x) x) doc:break) (list e1 e2)))
238(define doc4 ((doc:letblk 2 (doc:text "program") (doc:text "in") (doc:text "end"))
239              doc3 doc1))
240
241(print (sdoc->string (doc:format 32 doc4)))
242
243(print (sdoc->string (doc:format 10 doc4)))
244
245|#
Note: See TracBrowser for help on using the repository browser.